aboutsummaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs26
-rw-r--r--src/Eval.hs57
-rw-r--r--src/Helper.hs24
-rw-r--r--src/Parser.hs31
-rw-r--r--src/Reducer.hs3
5 files changed, 108 insertions, 33 deletions
diff --git a/src/Binary.hs b/src/Binary.hs
index 4575c49..fbf0a07 100644
--- a/src/Binary.hs
+++ b/src/Binary.hs
@@ -1,14 +1,17 @@
module Binary
( toBinary
, fromBinary
+ , toBitString
+ , fromBitString
) where
import Control.Applicative
+import qualified Data.BitString as Bit
import Data.Char
import Helper
toBinary :: Expression -> String
-toBinary (Bruijn x ) = (replicate x '1') ++ "0"
+toBinary (Bruijn x ) = (replicate (x + 1) '1') ++ "0"
toBinary (Abstraction exp ) = "00" ++ toBinary exp
toBinary (Application exp1 exp2) = "01" ++ (toBinary exp1) ++ (toBinary exp2)
@@ -25,3 +28,24 @@ fromBinary = foldr
showsBin n x = if n == 0
then id
else let (x', b) = divMod x 2 in showsBin (n - 1) x' . (intToDigit b :)
+
+-- TODO: Fix weird endianess things
+padBitList :: [Bool] -> [Bool]
+padBitList lst | length lst `mod` 8 == 0 = lst
+ | otherwise = padBitList ([False] ++ lst)
+
+toBitString :: String -> Bit.BitString
+toBitString = Bit.fromList . padBitList . map
+ (\case
+ '0' -> False
+ '1' -> True
+ )
+
+fromBitString :: Bit.BitString -> String
+fromBitString =
+ map
+ (\case
+ False -> '0'
+ True -> '1'
+ )
+ . Bit.toList
diff --git a/src/Eval.hs b/src/Eval.hs
index a5941c1..a5c29bf 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -5,6 +5,8 @@ module Eval
import Binary
import Control.Exception
import Control.Monad.State
+import qualified Data.BitString as Bit
+import qualified Data.ByteString as Byte
import Debug.Trace
import Helper
import Parser
@@ -66,6 +68,29 @@ eval (line : ls) env = case parse parseLine "FILE" line of
in case res of
Left err -> print err >> eval ls env'
Right _ -> eval ls env'
+ Import path ->
+ liftIO
+ $ (try $ readFile path :: IO (Either IOError String))
+ >>= (\case -- TODO: Make this more abstract and reusable
+ Left exception -> print (exception :: IOError) >> pure env
+ Right file -> eval (filter (not . null) $ lines file) [] >>= pure
+ )
+ Evaluate exp ->
+ let (res, env') = evalExp exp `runState` env
+ in putStrLn
+ (case res of
+ Left err -> show err
+ Right exp ->
+ "<> "
+ <> (show exp)
+ <> "\n*> "
+ <> (show reduced)
+ <> "\t("
+ <> (show $ binaryToDecimal reduced)
+ <> ")"
+ where reduced = reduce exp
+ )
+ >> eval ls env
Test exp1 exp2 ->
let (res, _) = evalTest exp1 exp2 `runState` env
in case res of
@@ -114,7 +139,7 @@ evalRepl line env = case parse parseReplLine "REPL" line of
where reduced = reduce exp
)
>> pure env
- Load path ->
+ Import path ->
liftIO
$ (try $ readFile path :: IO (Either IOError String))
>>= (\case -- TODO: Make this more abstract and reusable
@@ -145,26 +170,26 @@ evalFile path = do
Right file -> do
env <- eval (filter (not . null) $ lines file) []
case evalFunc "main" env of
- Nothing -> putStrLn $ "main function not found"
+ Nothing -> putStrLn $ "ERROR: main function not found"
Just exp -> print exp
-compile :: String -> IO ()
-compile path = do
+compile :: String -> (a -> IO ()) -> (String -> a) -> IO ()
+compile path write conv = do
file <- try $ readFile path :: IO (Either IOError String)
case file of
Left exception -> print (exception :: IOError)
Right file -> do
env <- eval (filter (not . null) $ lines file) []
case lookup "main" env of
- Nothing -> putStrLn $ "main function not found"
- Just exp -> putStrLn $ toBinary exp
+ Nothing -> putStrLn $ "ERROR: main function not found"
+ Just exp -> write $ conv $ toBinary exp
-exec :: String -> IO ()
-exec path = do
- file <- try $ readFile path :: IO (Either IOError String)
+exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
+exec path read conv = do
+ file <- read path
case file of
Left exception -> print (exception :: IOError)
- Right file -> print $ reduce $ fromBinary file
+ Right file -> print $ reduce $ fromBinary $ conv file
repl :: Environment -> InputT IO ()
repl env =
@@ -183,7 +208,11 @@ evalMain = do
case args of
[] -> runInputT defaultSettings { historyFile = Just ".bruijn-history" }
$ repl []
- ["-c", path] -> compile path -- TODO: -C: raw binary
- ["-e", path] -> exec path -- TODO: -E: raw binary
- [path] -> evalFile path
- _ -> usage
+ ["-c", path] ->
+ compile path (Byte.putStr . Bit.realizeBitStringStrict) toBitString
+ ["-C", path] -> compile path putStrLn id
+ ["-e", path] ->
+ exec path (try . Byte.readFile) (fromBitString . Bit.bitString)
+ ["-E", path] -> exec path (try . readFile) id
+ ['-' : _] -> usage
+ [path ] -> evalFile path
diff --git a/src/Helper.hs b/src/Helper.hs
index 57fb9f4..60941be 100644
--- a/src/Helper.hs
+++ b/src/Helper.hs
@@ -3,9 +3,8 @@ module Helper where
import Control.Monad.State
import Text.Parsec hiding ( State )
-data Error = SyntaxError ParseError | UndeclaredFunction String | DuplicateFunction String | InvalidIndex Int | FatalError String
+data Error = UndeclaredFunction String | DuplicateFunction String | InvalidIndex Int | FatalError String
instance Show Error where
- show (SyntaxError err) = show err
show (UndeclaredFunction err) = "ERROR: undeclared function " <> show err
show (DuplicateFunction err) = "ERROR: duplicate function " <> show err
show (InvalidIndex err) = "ERROR: invalid index " <> show err
@@ -14,7 +13,7 @@ type Failable = Either Error
data Expression = Bruijn Int | Variable String | Abstraction Expression | Application Expression Expression
deriving (Ord, Eq)
-data Instruction = Define String Expression | Evaluate Expression | Comment String | Load String | Test Expression Expression
+data Instruction = Define String Expression | Evaluate Expression | Comment String | Import String | Test Expression Expression
deriving (Show)
instance Show Expression where
show (Bruijn x ) = show x
@@ -25,24 +24,23 @@ instance Show Expression where
type Environment = [(String, Expression)]
type Program = State Environment
--- Dec to Bal3 in Bruijn encoding: reversed application with 1=>0; 0=>1; T=>2; end=>3
--- e.g. 0=0=[[[[3]]]]; 2=1T=[[[[2 (0 3)]]]] -5=T11=[[[[0 (0 (2 3))]]]]
-decimalToTernary :: Integer -> Expression
-decimalToTernary n =
- Abstraction $ Abstraction $ Abstraction $ Abstraction $ gen n
+decimalToBinary :: Integer -> Expression
+decimalToBinary n = Abstraction $ Abstraction $ Abstraction $ Abstraction $ gen
+ n
where -- TODO: Consider switching 0 and 1 for better readability
fix 0 = 1
fix 1 = 0
- fix 2 = 2
gen 0 = Bruijn 3
- gen n = Application (Bruijn $ fix $ mod n 3) (gen $ div (n + 1) 3)
+ gen 1 = Application (Bruijn 0) (gen 0)
+ gen n | n < 0 = Application (Bruijn 2) (gen (-n))
+ | otherwise = Application (Bruijn $ fix $ mod n 2) (gen $ div n 2)
-ternaryToDecimal :: Expression -> Integer
-ternaryToDecimal exp = sum $ zipWith (*) (resolve exp) (iterate (* 3) 1)
+binaryToDecimal :: Expression -> Integer
+binaryToDecimal exp = sum $ zipWith (*) (resolve exp) (iterate (* 2) 1)
where
multiplier (Bruijn 0) = 1
multiplier (Bruijn 1) = 0
- multiplier (Bruijn 2) = (-1)
+ multiplier (Bruijn 2) = -1 -- TODO
resolve' (Application x@(Bruijn _) (Bruijn 3)) = [multiplier x]
resolve' (Application fst@(Bruijn _) rst@(Application _ _)) =
(multiplier fst) : (resolve' rst)
diff --git a/src/Parser.hs b/src/Parser.hs
index 33b3c44..6df479d 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -35,6 +35,9 @@ almostAnything :: Parser String
almostAnything =
many1 $ oneOf ".`#~@$%^&*_+-=|;',/?[]<>(){} " <|> letter <|> digit
+importPath :: Parser String
+importPath = many1 $ oneOf "./_+-" <|> letter <|> digit
+
parseAbstraction :: Parser Expression
parseAbstraction = do
reservedOp "["
@@ -57,7 +60,7 @@ parseNumeral :: Parser Expression
parseNumeral = do
num <- number
spaces
- pure $ decimalToTernary num
+ pure $ decimalToBinary num
where
sign = (char '-' >> return negate) <|> (char '+' >> return id)
nat = read <$> many1 digit
@@ -104,8 +107,21 @@ parseReplDefine = do
parseComment :: Parser Instruction
parseComment = string "#" >> Comment <$> almostAnything
-parseLoad :: Parser Instruction
-parseLoad = string ":load " >> Load <$> almostAnything
+parseImport :: Parser Instruction
+parseImport = do
+ string ":import "
+ spaces
+ path <- importPath
+ spaces
+ pure $ Import $ path ++ ".bruijn"
+
+parsePrint :: Parser Instruction
+parsePrint = do
+ string ":print "
+ spaces
+ exp <- parseExpression
+ spaces
+ pure $ Evaluate exp
parseTest :: Parser Instruction
parseTest = do
@@ -118,12 +134,17 @@ parseTest = do
pure $ Test exp1 exp2
parseLine :: Parser Instruction
-parseLine = try parseDefine <|> try parseComment <|> try parseTest
+parseLine =
+ try parseDefine
+ <|> try parseComment
+ <|> try parsePrint
+ <|> try parseImport
+ <|> try parseTest
parseReplLine :: Parser Instruction
parseReplLine =
try parseReplDefine
<|> try parseComment
<|> try parseEvaluate
- <|> try parseLoad
+ <|> try parseImport
<|> try parseTest
diff --git a/src/Reducer.hs b/src/Reducer.hs
index a7c544a..2de307d 100644
--- a/src/Reducer.hs
+++ b/src/Reducer.hs
@@ -6,6 +6,9 @@ import Helper
-- TODO: Research interaction nets and optimal reduction
+-- TODO: Eta-reduction: [f 0] => f
+-- (Abstraction f@_ (Bruijn 0)) = f
+
(<+>) :: Expression -> Int -> Expression
(<+>) (Bruijn x ) n = if x > n then Bruijn (pred x) else Bruijn x
(<+>) (Application exp1 exp2) n = Application (exp1 <+> n) (exp2 <+> n)