Config, colors and completion

(the three c's were completely random btw)

1 files changed, 101 insertions, 59 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index 74bed01..5744e21 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -5,13 +5,17 @@ module Eval
 import           Binary
 import           Control.Exception
 import           Control.Monad.State
+import qualified Control.Monad.State.Strict    as StrictState
 import qualified Data.BitString                as Bit
 import qualified Data.ByteString               as Byte
+import           Data.List
 import           Debug.Trace
 import           Helper
 import           Parser
+import           Paths_bruijn
 import           Reducer
 import           System.Console.Haskeline
+import           System.Console.Haskeline.Completion
 import           System.Environment
 import           System.Exit
 import           System.IO
@@ -19,12 +23,17 @@ import           Text.Megaparsec         hiding ( State
                                                 , try
                                                 )
 
-loadFile :: String -> IO Environment
+data EnvState = EnvState
+  { _env :: Environment
+  }
+type M = StrictState.StateT EnvState IO
+
+loadFile :: String -> IO EnvState
 loadFile path = do
   file <- try $ readFile path :: IO (Either IOError String)
   case file of
-    Left  exception -> print (exception :: IOError) >> pure []
-    Right file      -> eval (filter (not . null) $ lines file) [] False
+    Left exception -> print (exception :: IOError) >> pure (EnvState [])
+    Right file -> eval (filter (not . null) $ lines file) (EnvState []) False
 
 evalVar :: String -> Program (Failable Expression)
 evalVar var = state $ \e ->
@@ -48,7 +57,6 @@ evalExp (    Variable    var) = evalVar var
 evalExp (    Abstraction exp) = evalExp exp >>= pure . fmap Abstraction
 evalExp (    Application f g) = evalApp f g
 
--- TODO: Duplicate function error
 evalDefine :: String -> Expression -> Program (Failable Expression)
 evalDefine name exp =
   evalExp exp
@@ -65,50 +73,55 @@ evalTest exp1 exp2 =
           Right exp1 -> fmap (Test exp1) <$> evalExp exp2
         )
 
-eval :: [String] -> Environment -> Bool -> IO Environment
-eval []          env _      = pure env
-eval (line : ls) env isRepl = case parse lineParser "BRUIJN" line of
-  Left  err   -> putStrLn (errorBundlePretty err) >> pure env
-  Right instr -> case instr of
-    Define name exp ->
-      let (res, env') = evalDefine name exp `runState` env
-      in  case res of
-            Left  err -> putStrLn (show err) >> eval ls env' isRepl
-            Right _   -> if isRepl
-              then (putStrLn $ name <> " = " <> show exp) >> pure env'
-              else eval ls env' isRepl
-    Import path -> loadFile path
-    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 isRepl
-    Test exp1 exp2 ->
-      let (res, _) = evalTest exp1 exp2 `runState` env
-      in  case res of
-            Left err -> putStrLn (show err) >> pure env
-            Right (Test exp1' exp2') ->
-              when
-                  (reduce exp1' /= reduce exp2')
-                  (  putStrLn
-                  $  "ERROR: test failed: "
-                  <> (show exp1)
-                  <> " != "
-                  <> (show exp2)
-                  )
-                >> eval ls env isRepl
-    _ -> eval ls env isRepl
+eval :: [String] -> EnvState -> Bool -> IO EnvState
+eval []   state@(EnvState env) _ = return state
+eval [""] state@(EnvState env) _ = return state
+eval (line : ls) state@(EnvState env) isRepl =
+  handleInterrupt (putStrLn "<aborted>" >> return state)
+    $ case parse lineParser "" line of
+        Left  err   -> putStrLn (errorBundlePretty err) >> eval ls state isRepl
+        Right instr -> case instr of
+          Define name exp ->
+            let (res, env') = evalDefine name exp `runState` env
+            in  case res of
+                  Left err ->
+                    putStrLn (show err) >> eval ls (EnvState env') isRepl
+                  Right _ -> if isRepl
+                    then (putStrLn $ name <> " = " <> show exp)
+                      >> return (EnvState env')
+                    else eval ls (EnvState env') isRepl
+          Import path -> loadFile path
+          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 state isRepl
+          Test exp1 exp2 ->
+            let (res, _) = evalTest exp1 exp2 `runState` env
+            in  case res of
+                  Left err -> putStrLn (show err) >> pure state
+                  Right (Test exp1' exp2') ->
+                    when
+                        (reduce exp1' /= reduce exp2')
+                        (  putStrLn
+                        $  "ERROR: test failed: "
+                        <> (show exp1)
+                        <> " != "
+                        <> (show exp2)
+                        )
+                      >> eval ls state isRepl
+          _ -> eval ls state isRepl
   where lineParser = if isRepl then parseReplLine else parseLine
 
 evalFunc :: String -> Environment -> Maybe Expression
@@ -116,17 +129,9 @@ evalFunc func env = do
   exp <- lookup func env
   pure $ reduce exp
 
-repl :: Environment -> InputT IO ()
-repl env =
-  getInputLine "λ "
-    >>= (\case
-          Nothing   -> pure ()
-          Just line -> (lift $ eval [line] env True) >>= repl
-        )
-
 evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
 evalFile path write conv = do
-  env <- loadFile path
+  EnvState env <- loadFile path
   case evalFunc "main" env of
     Nothing  -> putStrLn $ "ERROR: main function not found"
     Just exp -> write $ conv exp
@@ -138,6 +143,44 @@ exec path read conv = do
     Left  exception -> print (exception :: IOError)
     Right file      -> print $ reduce $ fromBinary $ conv file
 
+repl :: EnvState -> InputT M ()
+repl state =
+  (handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine
+      "\ESC[36mλ\ESC[0m "
+    )
+    >>= (\case
+          Nothing   -> return ()
+          Just line -> do
+            state <- (liftIO $ eval [line] state True)
+            lift (StrictState.put state)
+            repl state
+        )
+
+lookupCompletion :: String -> M [Completion]
+lookupCompletion str = do
+  (EnvState env) <- StrictState.get
+  return $ map (\(s, _) -> Completion s s False) $ filter
+    (\(s, _) -> str `isPrefixOf` s)
+    env
+
+completionSettings :: String -> Settings M
+completionSettings history = Settings
+  { complete       = completeWord Nothing " \n" lookupCompletion
+  , historyFile    = Just history
+  , autoAddHistory = True
+  }
+
+runRepl :: IO ()
+runRepl = do
+  config  <- getDataFileName "config"
+  history <- getDataFileName "history"
+  prefs   <- readPrefs config
+  let looper = runInputTWithPrefs prefs
+                                  (completionSettings history)
+                                  (withInterrupt $ repl (EnvState []))
+  code <- StrictState.evalStateT looper (EnvState [])
+  return code
+
 usage :: IO ()
 usage = putStrLn "Invalid arguments. Use 'bruijn [file]' instead"
 
@@ -145,8 +188,7 @@ evalMain :: IO ()
 evalMain = do
   args <- getArgs
   case args of
-    [] -> runInputT defaultSettings { historyFile = Just ".bruijn-history" }
-      $ repl []
+    []           -> runRepl
     ["-c", path] -> evalFile path
                              (Byte.putStr . Bit.realizeBitStringStrict)
                              (toBitString . toBinary)