Started typing

not like i've been typing for a long time lol

1 files changed, 33 insertions, 21 deletions

diff --git a/src/Eval.hs b/src/Eval.hs
index f6974de..6cf1fb8 100644
--- a/src/Eval.hs
+++ b/src/Eval.hs
@@ -13,7 +13,6 @@ import           Data.List
 import qualified Data.Map                      as M
 import           Data.Maybe
 import           Helper
--- import           Inet                           ( reduce )
 import           Parser
 import           Paths_bruijn
 import           Reducer
@@ -24,6 +23,7 @@ import           System.FilePath.Posix          ( takeBaseName )
 import           Text.Megaparsec         hiding ( State
                                                 , try
                                                 )
+import           Typer
 
 data EnvState = EnvState
   { _env   :: Environment
@@ -67,8 +67,8 @@ loadFile path conf cache = do
 evalFun :: Identifier -> Environment -> EvalState (Failable Expression)
 evalFun fun (Environment sub) = state $ \env@(Environment e) ->
   let lookup' env' = case M.lookup fun env' of
-        Nothing                    -> Left $ UndefinedIdentifier fun
-        Just (EnvDef { _exp = x }) -> Right x
+        Nothing                               -> Left $ UndefinedIdentifier fun
+        Just (EnvDef { _exp = x, _type = t }) -> Right $ TypedExpression t x
       matching n
         | null e = "<no idea>"
         | otherwise = snd $ minimumBy (compare `on` fst) $ map
@@ -122,26 +122,38 @@ evalMixfix m sub = resolve (mixfixKind m) mixfixArgs
 
 evalPrefix
   :: Identifier -> Expression -> Environment -> EvalState (Failable Expression)
+-- IDEA: typing and reduce if all arguments are fulfilled
+-- evalPrefix (PrefixFunction "⊩") e sub = evalExp e sub >>= \case
+--   Left  e' -> pure $ Left e'
+--   Right e' -> pure $ Right $ reduce e'
+-- evalPrefix p e sub = evalExp (Application (Function p) e) sub
 evalPrefix p e = evalExp $ Application (Function p) e
 
 evalExp :: Expression -> Environment -> EvalState (Failable Expression)
-evalExp idx@(Bruijn      _  ) = const $ pure $ Right idx
-evalExp (    Function    fun) = evalFun fun
-evalExp (    Abstraction e  ) = evalAbs e
-evalExp (    Application f g) = evalApp f g
-evalExp (    MixfixChain es ) = evalMixfix es
-evalExp (    Prefix p e     ) = evalPrefix p e
+evalExp idx@(Bruijn      _      ) = const $ pure $ Right idx
+evalExp (    Function    fun    ) = evalFun fun
+evalExp (    Abstraction e      ) = evalAbs e
+evalExp (    Application f g    ) = evalApp f g
+evalExp (    MixfixChain es     ) = evalMixfix es
+evalExp (    Prefix          p e) = evalPrefix p e
+evalExp (    TypedExpression t e) = error "invalid"
 
 evalDefinition
-  :: Identifier -> Expression -> Environment -> EvalState (Failable Expression)
-evalDefinition i e sub = evalExp e sub >>= \case
-  Left e' -> pure $ Left e'
-  Right f ->
-    modify
-        (\(Environment s) -> Environment
-          $ M.insert i (EnvDef f (Environment M.empty) defaultFlags) s
-        )
-      >> pure (Right f)
+  :: Identifier
+  -> Expression
+  -> Type
+  -> Environment
+  -> EvalState (Failable Expression)
+evalDefinition i e t sub = evalExp e sub >>= \case
+  Left  e' -> pure $ Left e'
+  Right f  -> case typeCheck f t of
+    err@(Left _) -> pure err
+    Right f' ->
+      modify
+          (\(Environment s) -> Environment
+            $ M.insert i (EnvDef f' t (Environment M.empty) defaultFlags) s
+          )
+        >> pure (Right f)
 
 evalTest
   :: Expression -> Expression -> Environment -> EvalState (Failable Command)
@@ -262,9 +274,9 @@ evalInstruction
   :: Instruction -> EnvState -> (EnvState -> IO EnvState) -> IO EnvState
 evalInstruction (ContextualInstruction instr inp) s@(EnvState env conf _) rec =
   case instr of
-    Define i e sub -> do
-      EnvState subEnv _     _ <- evalSubEnv sub s
-      (        res    , env') <- pure $ evalDefinition i e subEnv `runState` env
+    Define i e t sub -> do
+      EnvState subEnv _ _ <- evalSubEnv sub s
+      (res, env') <- pure $ evalDefinition i e t subEnv `runState` env
       case res of
         Left err ->
           print (ContextualError err $ Context inp $ _nicePath conf) >> pure s -- don't continue