General improvements

1 files changed, 159 insertions, 100 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index 9978a45..fdaa2cb 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -33,7 +33,8 @@ split _  [] = []
 split [] x  = map (: []) x
 split a@(_ : _) b@(c : _)
   | Just suffix <- a `stripPrefix` b = [] : split a suffix
-  | otherwise = if null rest then [[c]] else (c : head rest) : tail rest
+  | null rest                        = [[c]]
+  | otherwise                        = (c : head rest) : tail rest
   where rest = split a $ tail b
 
 -- TODO: Force naming convention for namespaces/files
@@ -42,9 +43,17 @@ loadFile path conf = do
   f <- try $ readFile path :: IO (Either IOError String)
   case f of
     Left exception ->
-      print (ContextualError (ImportError $ show (exception :: IOError)) (Context "" $ nicePath conf)) >> pure (EnvState (Environment []) conf)
-    Right f' -> eval (filter (not . null) $ split "\n\n" f')
-                       (EnvState (Environment []) (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) }))
+      print
+          (ContextualError (ImportError $ show (exception :: IOError))
+                           (Context "" $ nicePath conf)
+          )
+        >> pure (EnvState (Environment []) conf)
+    Right f' -> eval
+      (filter (not . null) $ split "\n\n" f')
+      (EnvState
+        (Environment [])
+        (conf { isRepl = False, evalPaths = (path : (evalPaths conf)) })
+      )
 
 evalVar :: String -> Environment -> Program (Failable Expression)
 evalVar var (Environment sub) = state $ \env@(Environment e) ->
@@ -58,7 +67,8 @@ evalVar var (Environment sub) = state $ \env@(Environment e) ->
 evalAbs :: Expression -> Environment -> Program (Failable Expression)
 evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction
 
-evalApp :: Expression -> Expression -> Environment -> Program (Failable Expression)
+evalApp
+  :: Expression -> Expression -> Environment -> Program (Failable Expression)
 evalApp f g sub =
   evalExp f sub
     >>= (\case
@@ -66,19 +76,26 @@ evalApp f g sub =
           Right f' -> fmap (Application f') <$> evalExp g sub
         )
 
-evalInfix :: Expression -> String -> Expression -> Environment -> Program (Failable Expression)
-evalInfix le i re = evalExp $ Application (Application (Variable $ "(" ++ i ++ ")") le) re
+evalInfix
+  :: Expression
+  -> String
+  -> Expression
+  -> Environment
+  -> Program (Failable Expression)
+evalInfix le i re =
+  evalExp $ Application (Application (Variable $ "(" ++ i ++ ")") le) re
 
-evalPrefix :: String -> Expression -> Environment -> Program (Failable Expression)
+evalPrefix
+  :: String -> Expression -> Environment -> Program (Failable Expression)
 evalPrefix p e = evalExp $ Application (Variable $ p ++ "(") e
 
 evalExp :: Expression -> Environment -> Program (Failable Expression)
 evalExp idx@(Bruijn      _  ) = const $ pure $ Right idx
 evalExp (    Variable    var) = evalVar var
-evalExp (    Abstraction e) = evalAbs e
+evalExp (    Abstraction e  ) = evalAbs e
 evalExp (    Application f g) = evalApp f g
-evalExp (Infix le i re) = evalInfix le i re
-evalExp (Prefix p e) = evalPrefix p e
+evalExp (    Infix le i re  ) = evalInfix le i re
+evalExp (    Prefix p e     ) = evalPrefix p e
 
 evalDefine
   :: String -> Expression -> Environment -> Program (Failable Expression)
@@ -87,11 +104,15 @@ evalDefine name e sub =
     >>= (\case
           Left e' -> pure $ Left e'
           Right f ->
-            modify (\(Environment s) -> Environment $ ((name, f), Environment []) : s)
+            modify
+                (\(Environment s) ->
+                  Environment $ ((name, f), Environment []) : s
+                )
               >> pure (Right f)
         )
 
-evalTest :: Expression -> Expression -> Environment -> Program (Failable Instruction)
+evalTest
+  :: Expression -> Expression -> Environment -> Program (Failable Instruction)
 evalTest e1 e2 sub =
   evalExp e1 sub
     >>= (\case
@@ -102,7 +123,8 @@ evalTest e1 e2 sub =
 evalSubEnv :: [Instruction] -> EnvState -> IO EnvState
 evalSubEnv [] s = return s
 evalSubEnv (instr : is) s =
-  handleInterrupt (putStrLn "<aborted>" >> return s) $ evalInstruction instr s (evalSubEnv is)
+  handleInterrupt (putStrLn "<aborted>" >> return s)
+    $ evalInstruction instr s (evalSubEnv is)
 
 fullPath :: String -> IO String
 fullPath path = do
@@ -111,72 +133,85 @@ fullPath path = do
   pure $ if exists then lib else path
 
 evalInstruction
-  :: Instruction
-  -> EnvState
-  -> (EnvState -> IO EnvState)
-  -> IO EnvState
-evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec = case instr of
-  Define name e sub -> do
-    EnvState subEnv _ <- evalSubEnv sub s
-    let
-      (res, env') = evalDefine name e subEnv `runState` env
-     in  case res of
-          Left  err -> print (ContextualError err $ Context inp $ nicePath conf) >> pure s -- don't continue
-          Right _   -> if isRepl conf
-            then (putStrLn $ name <> " = " <> show e)
-              >> return (EnvState env' conf)
-            else rec (EnvState env' conf)
-  Input path -> do
-    full <- fullPath path
-    if full `elem` evalPaths conf then print (ContextualError (ImportError path) (Context inp $ nicePath conf)) >> pure s else do
-      EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error
-      conf'' <- pure $ conf { tested = path : (tested conf' <> tested conf) }
-      rec (EnvState (env' <> env) conf'') -- import => isRepl = False
-  -- TODO: Don't import subimports into main env
-  Import path namespace -> do
-    full <- fullPath path
-    if full `elem` evalPaths conf then print (ContextualError (ImportError path) (Context inp $ nicePath conf)) >> pure s else do
-      EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error
-      conf'' <- pure $ conf { tested = path : (tested conf') }
-      let prefix | null namespace   = takeBaseName path ++ "."
-                 | namespace == "." = ""
-                 | otherwise        = namespace ++ "."
-      env'' <- pure $ Environment $ map (\((n, e), o) -> ((prefix ++ n, e), o))
-                                       ((\(Environment e) -> e) env') -- TODO: Improve
-      rec (EnvState (env'' <> env) conf'') -- import => isRepl = False
-  Evaluate e ->
-    let (res, _) = evalExp e (Environment []) `runState` env
-    in  putStrLn
-            (case res of
-              Left err -> show err
-              Right e' ->
-                "<> "
-                  <> (show e')
-                  <> "\n*> "
-                  <> (show reduced)
-                  <> " "
-                  <> (humanifyExpression reduced)
-                  <> " "
-                  <> (matchingFunctions reduced env)
-                where reduced = reduce e'
-            )
-          >> rec s
-  Test e1 e2 -> if evalTests conf && (nicePath conf) `notElem` (tested conf) then
-    let (res, _) = evalTest e1 e2 (Environment []) `runState` env
-    in  case res of
-          Left err -> print (ContextualError err $ Context inp $ nicePath conf) >> pure s
-          Right (Test e1' e2') ->
-            when
-                (lhs /= rhs)
-                (print $ FailedTest e1 e2 lhs rhs)
-              >> print (nicePath conf) >> print (e1) >> rec s
-            where
-              lhs = reduce e1'
-              rhs = reduce e2'
-          _ -> rec s
-    else rec s
-  _ -> rec s
-evalInstruction instr s rec = evalInstruction (ContextualInstruction instr "<unknown>") s rec
+  :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState
+evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf) rec =
+  case instr of
+    Define name e sub -> do
+      EnvState subEnv _ <- evalSubEnv sub s
+      (res, env')       <- pure $ evalDefine name e subEnv `runState` env
+      case res of
+        Left err ->
+          print (ContextualError err $ Context inp $ nicePath conf) >> pure s -- don't continue
+        Right _
+          | isRepl conf -> (putStrLn $ name <> " = " <> show e)
+          >> return (EnvState env' conf)
+          | otherwise -> rec $ EnvState env' conf
+    Input path -> do
+      full <- fullPath path
+      if full `elem` evalPaths conf
+        then
+          print
+              (ContextualError (ImportError path) (Context inp $ nicePath conf))
+            >> pure s
+        else do
+          EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error
+          conf''              <- pure
+            $ conf { tested = path : (tested conf' <> tested conf) }
+          rec $ EnvState (env' <> env) conf'' -- import => isRepl = False
+    -- TODO: Don't import subimports into main env
+    Import path namespace -> do
+      full <- fullPath path
+      if full `elem` evalPaths conf
+        then
+          print
+              (ContextualError (ImportError path) (Context inp $ nicePath conf))
+            >> pure s
+        else do
+          EnvState env' conf' <- loadFile full (conf { nicePath = path }) -- TODO: Fix wrong `within` in import error
+          conf''              <- pure $ conf { tested = path : (tested conf') }
+          let prefix | null namespace   = takeBaseName path ++ "."
+                     | namespace == "." = ""
+                     | otherwise        = namespace ++ "."
+          env'' <- pure $ Environment $ map
+            (\((n, e), o) -> ((prefix ++ n, e), o))
+            ((\(Environment e) -> e) env') -- TODO: Improve
+          rec $ EnvState (env'' <> env) conf'' -- import => isRepl = False
+    Evaluate e ->
+      let (res, _) = evalExp e (Environment []) `runState` env
+      in  putStrLn
+              (case res of
+                Left err -> show err
+                Right e' ->
+                  "<> "
+                    <> (show e')
+                    <> "\n*> "
+                    <> (show reduced)
+                    <> " "
+                    <> (humanifyExpression reduced)
+                    <> " "
+                    <> (matchingFunctions reduced env)
+                  where reduced = reduce e'
+              )
+            >> rec s
+    Test e1 e2
+      | evalTests conf && (nicePath conf) `notElem` (tested conf)
+      -> let (res, _) = evalTest e1 e2 (Environment []) `runState` env
+         in
+           case res of
+             Left err ->
+               print (ContextualError err $ Context inp $ nicePath conf)
+                 >> pure s
+             Right (Test e1' e2') ->
+               when (lhs /= rhs) (print $ FailedTest e1 e2 lhs rhs) >> rec s
+              where
+               lhs = reduce e1'
+               rhs = reduce e2'
+             _ -> rec s
+      | otherwise
+      -> rec s
+    _ -> rec s
+evalInstruction instr s rec =
+  evalInstruction (ContextualInstruction instr "<unknown>") s rec
 
 eval :: [String] -> EnvState -> IO EnvState
 eval []   s = return s
@@ -184,46 +219,65 @@ eval [""] s = return s
 eval (block : bs) s@(EnvState _ conf) =
   handleInterrupt (putStrLn "<aborted>" >> return s)
     $ case parse blockParser "" block of
-        Left  err   -> print (ContextualError (SyntaxError $ printBundle err) (Context "" $ nicePath conf)) >> eval bs s
+        Left err ->
+          print
+              (ContextualError (SyntaxError $ printBundle err)
+                               (Context "" $ nicePath conf)
+              )
+            >> eval bs s
         Right instr -> evalInstruction instr s (eval bs)
-  where blockParser = if isRepl conf then parseReplLine else parseBlock 0
+ where
+  blockParser | isRepl conf = parseReplLine
+              | otherwise   = parseBlock 0
 
 evalMainFunc :: Environment -> Expression -> Maybe Expression
 evalMainFunc (Environment env) arg = do
   e <- lookup "main" (map fst env)
   pure $ reduce $ Application e arg
 
-evalFileConf :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> ExpCache -> IO ()
-evalFileConf path wr conv conf cache = do
-  EnvState env _ _ <- loadFile path conf cache
-  arg          <- encodeStdin
+evalFileConf
+  :: String -> (a -> IO ()) -> (Expression -> a) -> EvalConf -> IO ()
+evalFileConf path wr conv conf = do
+  EnvState env _ <- loadFile path conf
+  arg            <- encodeStdin
   case evalMainFunc env arg of
-    Nothing  -> print $ ContextualError (UndeclaredFunction "main") (Context "" path)
+    Nothing ->
+      print $ ContextualError (UndeclaredFunction "main") (Context "" path)
     Just e -> wr $ conv e
 
 defaultConf :: String -> EvalConf
-defaultConf path = EvalConf { isRepl = False, evalTests = True, nicePath = path, tested = [], evalPaths = [] }
+defaultConf path = EvalConf { isRepl    = False
+                            , evalTests = True
+                            , nicePath  = path
+                            , tested    = []
+                            , evalPaths = []
+                            }
 
 reduceFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
 reduceFile path wr conv = do
-  EnvState (Environment env) _ _ <- loadFile path (defaultConf path) H.empty
+  EnvState (Environment env) _ <- loadFile path (defaultConf path)
   case lookup "main" (map fst env) of
-    Nothing  -> print $ ContextualError (UndeclaredFunction "main") (Context "" path)
+    Nothing ->
+      print $ ContextualError (UndeclaredFunction "main") (Context "" path)
     Just e -> wr $ conv e
 
 evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
-evalFile path wr conv = evalFileConf path wr conv (defaultConf path) H.empty
+evalFile path wr conv = evalFileConf path wr conv (defaultConf path)
 
 -- TODO: Merge with evalFile
 evalYolo :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
-evalYolo path wr conv = evalFileConf path wr conv (defaultConf path) { evalTests = False } H.empty
+evalYolo path wr conv =
+  evalFileConf path wr conv (defaultConf path) { evalTests = False }
 
 exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
 exec path rd conv = do
-  f <- rd path
+  f   <- rd path
+  arg <- encodeStdin
   case f of
     Left  exception -> print (exception :: IOError)
-    Right f'      -> putStr $ humanifyExpression $ reduce' $ Application (fromBinary $ conv f') arg
+    Right f'        -> putStr $ humanifyExpression $ reduce $ Application
+      (fromBinary $ conv f')
+      arg
 
 repl :: EnvState -> InputT M ()
 repl (EnvState env conf) =
@@ -258,12 +312,17 @@ runRepl = do
   history <- getDataFileName "history"
   prefs   <- readPrefs config
   let -- TODO: Use -y in repl for YOLO lifestyle
-    conf = EvalConf { isRepl = True, evalTests = True, nicePath = "<repl>", tested = [], evalPaths = [] }
-    looper = runInputTWithPrefs
+      conf = EvalConf { isRepl    = True
+                      , evalTests = True
+                      , nicePath  = "<repl>"
+                      , tested    = []
+                      , evalPaths = []
+                      }
+      looper = runInputTWithPrefs
         prefs
         (completionSettings history)
-        (withInterrupt $ repl $ EnvState (Environment []) conf H.empty)
-  code <- StrictState.evalStateT looper (EnvState (Environment []) conf H.empty)
+        (withInterrupt $ repl $ EnvState (Environment []) conf)
+  code <- StrictState.evalStateT looper (EnvState (Environment []) conf)
   return code
 
 usage :: IO ()
@@ -287,8 +346,8 @@ evalMain = do
   case args of
     []           -> runRepl
     ["-b", path] -> reduceFile path
-                             (Byte.putStr . Bit.realizeBitStringStrict)
-                             (toBitString . toBinary)
+                               (Byte.putStr . Bit.realizeBitStringStrict)
+                               (toBitString . toBinary)
     ["-B", path] -> reduceFile path putStrLn toBinary
     ["-e", path] ->
       exec path (try . Byte.readFile) (fromBitString . Bit.bitString)