diff options
| author | Marvin Borner | 2023-11-06 18:53:58 +0100 |
|---|---|---|
| committer | Marvin Borner | 2023-11-06 18:53:58 +0100 |
| commit | 0a6c4aed69622751058da16f297e5a8f8fe01a1b (patch) | |
| tree | f0e12021e7243987288b70a91e338490e30223f0 /src/Eval.hs | |
| parent | 27f0cbf21e01448245d54f7818582c741d8cdafa (diff) | |
Started unquote and improved quote
Diffstat (limited to 'src/Eval.hs')
| -rw-r--r-- | src/Eval.hs | 22 |
1 files changed, 21 insertions, 1 deletions
diff --git a/src/Eval.hs b/src/Eval.hs index 6af1959..223a43a 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -131,6 +131,24 @@ evalPrefix :: Identifier -> Expression -> Environment -> EvalState (Failable Expression) evalPrefix p e = evalExp $ Application (Function p) e +evalQuote :: Expression -> Environment -> EvalState (Failable Expression) +evalQuote f sub = evalExp f sub >>= \case + Left e -> pure $ Left e + Right f' -> pure $ Right $ quotify f' + where + base l r = Abstraction $ Abstraction $ Abstraction $ Application l r + quotify (Abstraction e) = base (Bruijn 0) (quotify e) + quotify (Application l r) = + base (Application (Bruijn 1) (quotify l)) (quotify r) + quotify (Bruijn i) = base (Bruijn 2) (decimalToUnary $ fromIntegral i) + quotify (Unquote e) = quotify e + quotify _ = invalidProgramState + +evalUnquote :: Expression -> Environment -> EvalState (Failable Expression) +evalUnquote f sub = evalExp f sub >>= \case + Left e -> pure $ Left e + Right f' -> pure $ Right $ Unquote $ unsafeReduce f' + evalExp :: Expression -> Environment -> EvalState (Failable Expression) evalExp idx@(Bruijn _ ) = const $ pure $ Right idx evalExp ( Function fun) = evalFun fun @@ -138,6 +156,8 @@ 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 ( Quote e ) = evalQuote e +evalExp ( Unquote e ) = evalUnquote e evalDefinition :: Identifier -> Expression -> Environment -> EvalState (Failable Expression) @@ -290,7 +310,7 @@ evalCommand inp s@(EnvState env@(Environment envDefs) conf cache) = \case putStrLn $ toBinary red pure s Jot str -> do - let e = fromJot str + let e = fromJot str let (res, _) = evalExp e (Environment M.empty) `runState` env case res of Left err -> print err |