From 633e93e29f98da06b7f09dfa248ab27993a654d5 Mon Sep 17 00:00:00 2001
From: Marvin Borner
Date: Thu, 16 Jun 2022 19:21:04 +0200
Subject: Basic compilation support

---
 src/Binary.hs | 27 +++++++++++++++++++++++++++
 src/Eval.hs   | 46 ++++++++++++++++++++++++++++++++++------------
 2 files changed, 61 insertions(+), 12 deletions(-)
 create mode 100644 src/Binary.hs

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
-- 
cgit v1.2.3