Things

lol

1 files changed, 66 insertions, 77 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index 03d5bd5..0eb6c9e 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -8,20 +8,15 @@ 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.Either
 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.Directory
 import           System.Environment
-import           System.Exit
 import           System.FilePath.Posix          ( takeBaseName )
-import           System.IO
 import           Text.Megaparsec         hiding ( State
                                                 , try
                                                 )
@@ -35,7 +30,7 @@ type M = StrictState.StateT EnvState IO
 split :: (Eq a) => [a] -> [a] -> [[a]]
 split _  [] = []
 split [] x  = map (: []) x
-split a@(d : ds) b@(c : cs)
+split a@(_ : _) b@(c : _)
   | Just suffix <- a `stripPrefix` b = [] : split a suffix
   | otherwise = if null rest then [[c]] else (c : head rest) : tail rest
   where rest = split a $ tail b
@@ -43,25 +38,25 @@ split a@(d : ds) b@(c : cs)
 -- TODO: Force naming convention for namespaces/files
 loadFile :: String -> IO EnvState
 loadFile path = do
-  file <- try $ readFile path :: IO (Either IOError String)
-  case file of
+  f <- try $ readFile path :: IO (Either IOError String)
+  case f of
     Left exception ->
       print (exception :: IOError) >> pure (EnvState $ Environment [])
-    Right file -> eval (filter (not . null) $ split "\n\n" file)
+    Right f' -> eval (filter (not . null) $ split "\n\n" f')
                        (EnvState $ Environment [])
                        False
 
 evalVar :: String -> Environment -> Program (Failable Expression)
 evalVar var (Environment sub) = state $ \env@(Environment e) ->
-  let find name env = case lookup name env of
+  let lookup' name env' = case lookup name env' of
         Nothing -> Left $ UndeclaredFunction var
         Just x  -> Right x
-  in  case find var (map fst sub) of
+  in  case lookup' var (map fst sub) of -- search in sub env
         s@(Right _) -> (s, env)
-        _           -> (find var (map fst e), env) -- search in global env
+        _           -> (lookup' var (map fst e), env) -- search in global env
 
 evalAbs :: Expression -> Environment -> Program (Failable Expression)
-evalAbs exp sub = evalExp exp sub >>= pure . fmap Abstraction
+evalAbs e sub = evalExp e sub >>= pure . fmap Abstraction
 
 evalApp :: Expression -> Expression -> Environment -> Program (Failable Expression)
 evalApp f g sub =
@@ -74,33 +69,33 @@ evalApp f g sub =
 evalExp :: Expression -> Environment -> Program (Failable Expression)
 evalExp idx@(Bruijn      _  ) = const $ pure $ Right idx
 evalExp (    Variable    var) = evalVar var
-evalExp (    Abstraction exp) = evalAbs exp
+evalExp (    Abstraction e) = evalAbs e
 evalExp (    Application f g) = evalApp f g
 
 evalDefine
   :: String -> Expression -> Environment -> Program (Failable Expression)
-evalDefine name exp sub =
-  evalExp exp sub
+evalDefine name e sub =
+  evalExp e sub
     >>= (\case
-          Left e -> pure $ Left e
+          Left e' -> pure $ Left e'
           Right f ->
             modify (\(Environment s) -> Environment $ ((name, f), Environment []) : s)
               >> pure (Right f)
         )
 
 evalTest :: Expression -> Expression -> Environment -> Program (Failable Instruction)
-evalTest exp1 exp2 sub =
-  evalExp exp1 sub
+evalTest e1 e2 sub =
+  evalExp e1 sub
     >>= (\case
-          Left  exp1 -> pure $ Left exp1
-          Right exp1 -> fmap (Test exp1) <$> evalExp exp2 sub
+          Left  err -> pure $ Left err
+          Right e1' -> fmap (Test e1') <$> evalExp e2 sub
         )
 
 evalSubEnv :: [Instruction] -> EnvState -> Bool -> IO EnvState
-evalSubEnv [] state _ = return state
-evalSubEnv (instr : is) state@(EnvState env) isRepl =
-  handleInterrupt (putStrLn "<aborted>" >> return state)
-    $ evalInstruction instr state (evalSubEnv is) isRepl
+evalSubEnv [] s _ = return s
+evalSubEnv (instr : is) s isRepl =
+  handleInterrupt (putStrLn "<aborted>" >> return s)
+    $ evalInstruction instr s (evalSubEnv is) isRepl
 
 evalInstruction
   :: Instruction
@@ -108,15 +103,15 @@ evalInstruction
   -> (EnvState -> Bool -> IO EnvState)
   -> Bool
   -> IO EnvState
-evalInstruction instr state@(EnvState env) rec isRepl = case instr of
-  Define name exp sub -> do
-    EnvState subEnv <- evalSubEnv sub state isRepl
+evalInstruction instr s@(EnvState env) rec isRepl = case instr of
+  Define name e sub inp -> do
+    EnvState subEnv <- evalSubEnv sub s isRepl
     let
-      (res, env') = evalDefine name exp subEnv `runState` env
+      (res, env') = evalDefine name e subEnv `runState` env
      in  case res of
-          Left  err -> print err >> rec (EnvState env') isRepl
+          Left  err -> print (ContextualError err inp) >> pure s -- don't continue
           Right _   -> if isRepl
-            then (putStrLn $ name <> " = " <> show exp)
+            then (putStrLn $ name <> " = " <> show e)
               >> return (EnvState env')
             else rec (EnvState env') isRepl
   -- TODO: Import loop detection
@@ -128,88 +123,82 @@ evalInstruction instr state@(EnvState env) rec isRepl = case instr of
     let prefix | null namespace   = takeBaseName path ++ "."
                | namespace == "." = ""
                | otherwise        = namespace ++ "."
-    env' <- pure $ Environment $ map (\((n, e), s) -> ((prefix ++ n, e), s))
+    env'' <- pure $ Environment $ map (\((n, e), o) -> ((prefix ++ n, e), o))
                                      ((\(Environment e) -> e) env') -- TODO: Improve
-    rec (EnvState $ env <> env') False -- import => isRepl = False
-  Evaluate exp ->
-    let (res, env') = evalExp exp (Environment []) `runState` env
+    rec (EnvState $ env <> env'') False -- import => isRepl = False
+  Evaluate e ->
+    let (res, _) = evalExp e (Environment []) `runState` env
     in  putStrLn
             (case res of
               Left err -> show err
-              Right exp ->
+              Right e' ->
                 "<> "
-                  <> (show exp)
+                  <> (show e')
                   <> "\n*> "
                   <> (show reduced)
                   <> (if likeTernary reduced
                        then "\t(" <> (show $ ternaryToDecimal reduced) <> ")"
                        else ""
                      )
-                where reduced = reduce exp
+                where reduced = reduce e'
             )
-          >> rec state isRepl
-  Test exp1 exp2 ->
-    let (res, _) = evalTest exp1 exp2 (Environment []) `runState` env
+          >> rec s isRepl
+  Test e1 e2 ->
+    let (res, _) = evalTest e1 e2 (Environment []) `runState` env
     in  case res of
-          Left err -> print err >> pure state
-          Right (Test exp1' exp2') ->
+          Left err -> print err >> pure s
+          Right (Test e1' e2') ->
             when
-                (reduce exp1' /= reduce exp2')
-                (  putStrLn
-                $  "ERROR: test failed: "
-                <> (show exp1)
-                <> " != "
-                <> (show exp2)
-                )
-              >> rec state isRepl
-  _ -> rec state isRepl
+                (lhs /= rhs)
+                (print $ FailedTest e1 e2 lhs rhs)
+              >> rec s isRepl
+            where
+              lhs = reduce e1'
+              rhs = reduce e2'
+          _ -> rec s isRepl
+  _ -> rec s isRepl
 
 eval :: [String] -> EnvState -> Bool -> IO EnvState
-eval []   state _ = return state
-eval [""] state _ = return state
-eval (block : bs) state@(EnvState env) isRepl =
-  handleInterrupt (putStrLn "<aborted>" >> return state)
+eval []   s _ = return s
+eval [""] s _ = return s
+eval (block : bs) s isRepl =
+  handleInterrupt (putStrLn "<aborted>" >> return s)
     $ case parse blockParser "" block of
-        Left  err   -> putStrLn (errorBundlePretty err) >> eval bs state isRepl
-        Right instr -> evalInstruction instr state (eval bs) isRepl
+        Left  err   -> print (SyntaxError $ errorBundlePretty err) >> eval bs s isRepl
+        Right instr -> evalInstruction instr s (eval bs) isRepl
   where blockParser = if isRepl then parseReplLine else parseBlock 0
 
-evalFunc :: String -> Environment -> Maybe Expression
-evalFunc func (Environment env) = do
-  exp <- lookup func (map fst env)
-  pure $ reduce exp
-
 evalMainFunc :: Environment -> Expression -> Maybe Expression
 evalMainFunc (Environment env) arg = do
-  exp <- lookup "main" (map fst env)
-  pure $ reduce $ Application exp arg
+  e <- lookup "main" (map fst env)
+  pure $ reduce $ Application e arg
 
 evalFile :: String -> (a -> IO ()) -> (Expression -> a) -> IO ()
-evalFile path write conv = do
+evalFile path wr conv = do
   EnvState env <- loadFile path
   arg          <- encodeStdin
   case evalMainFunc env arg of
-    Nothing  -> putStrLn "ERROR: main function not found"
-    Just exp -> write $ conv exp
+    Nothing  -> print $ ContextualError (UndeclaredFunction "main") path
+    Just e -> wr $ conv e
 
 exec :: String -> (String -> IO (Either IOError a)) -> (a -> String) -> IO ()
-exec path read conv = do
-  file <- read path
-  case file of
+exec path rd conv = do
+  f <- rd path
+  case f of
     Left  exception -> print (exception :: IOError)
-    Right file      -> print $ reduce $ fromBinary $ conv file
+    Right f'      -> print $ reduce $ fromBinary $ conv f'
 
 repl :: EnvState -> InputT M ()
-repl state =
+repl s =
   (handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine
       "\ESC[36mλ\ESC[0m "
     )
-    >>= (\case
+    >>= (\case -- TODO: Add non-parser error support for REPL
           Nothing   -> return ()
           Just line -> do
-            state <- (liftIO $ eval [line] state True)
-            lift (StrictState.put state)
-            repl state
+            s' <- (liftIO $ eval [line] s True)
+            lift (StrictState.put s')
+            repl s'
         )
 
 lookupCompletion :: String -> M [Completion]