diff options
| -rw-r--r-- | src/Binary.hs | 27 | ||||
| -rw-r--r-- | src/Eval.hs | 46 |
2 files changed, 61 insertions, 12 deletions
diff --git a/src/Binary.hs b/src/Binary.hs new file mode 100644 index 0000000..4575c49 --- /dev/null +++ b/src/Binary.hs @@ -0,0 +1,27 @@ +module Binary + ( toBinary + , fromBinary + ) where + +import Control.Applicative +import Data.Char +import Helper + +toBinary :: Expression -> String +toBinary (Bruijn x ) = (replicate x '1') ++ "0" +toBinary (Abstraction exp ) = "00" ++ toBinary exp +toBinary (Application exp1 exp2) = "01" ++ (toBinary exp1) ++ (toBinary exp2) + +-- Stolen from John Tromp +fromBinary :: String -> Expression +fromBinary = foldr + (\x -> Abstraction . (Application . Application (Bruijn 0) . code $ x)) + nil + where + nil = code '1' + code '0' = Abstraction (Abstraction (Bruijn 1)) + code '1' = Abstraction (Abstraction (Bruijn 0)) + code x = fromBinary (showsBin 8 (ord x) "") + showsBin n x = if n == 0 + then id + else let (x', b) = divMod x 2 in showsBin (n - 1) x' . (intToDigit b :) diff --git a/src/Eval.hs b/src/Eval.hs index c65bf0e..a5941c1 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -2,6 +2,7 @@ module Eval ( evalMain ) where +import Binary import Control.Exception import Control.Monad.State import Debug.Trace @@ -81,10 +82,10 @@ eval (line : ls) env = case parse parseLine "FILE" line of >> eval ls env _ -> eval ls env -evalFunc :: String -> Environment -> IO Environment -evalFunc func env = case lookup func env of - Nothing -> (putStrLn $ func <> " not found") >> pure env - Just exp -> (print $ reduce exp) >> pure env +evalFunc :: String -> Environment -> Maybe Expression +evalFunc func env = do + exp <- lookup func env + pure $ reduce exp -- TODO: Less duplicate code (liftIO?) -- TODO: Generally improve eval code @@ -108,7 +109,7 @@ evalRepl line env = case parse parseReplLine "REPL" line of <> "\n*> " <> (show reduced) <> "\t(" - <> (show $ ternaryToDecimal reduced) + <> (show $ binaryToDecimal reduced) <> ")" where reduced = reduce exp ) @@ -140,11 +141,30 @@ evalFile :: String -> IO () evalFile path = do file <- try $ readFile path :: IO (Either IOError String) case file of - Left exception -> print (exception :: IOError) - Right file -> - eval (filter (not . null) $ lines file) [] - >>= evalFunc "main" - >> return () + Left exception -> print (exception :: IOError) + Right file -> do + env <- eval (filter (not . null) $ lines file) [] + case evalFunc "main" env of + Nothing -> putStrLn $ "main function not found" + Just exp -> print exp + +compile :: String -> IO () +compile path = 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 + +exec :: String -> IO () +exec path = do + file <- try $ readFile path :: IO (Either IOError String) + case file of + Left exception -> print (exception :: IOError) + Right file -> print $ reduce $ fromBinary file repl :: Environment -> InputT IO () repl env = @@ -163,5 +183,7 @@ evalMain = do case args of [] -> runInputT defaultSettings { historyFile = Just ".bruijn-history" } $ repl [] - [path] -> evalFile path - _ -> usage + ["-c", path] -> compile path -- TODO: -C: raw binary + ["-e", path] -> exec path -- TODO: -E: raw binary + [path] -> evalFile path + _ -> usage |