Big file-structure refactor

1 files changed, 100 insertions, 0 deletions

diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs
new file mode 100644
index 0000000..a53be8b
--- /dev/null
+++ b/DSL/Interpretation.hs
@@ -0,0 +1,100 @@
+module DSL.Interpretation where
+
+import Data.Foldable (foldlM)
+
+import DSL.Types
+import DSL.Util
+import DSL.Intrinsics
+
+newMachine :: Machine
+newMachine = Machine { ok=True, stack=[] }
+
+pushData :: Machine -> StackData -> Machine
+pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
+
+runModifier :: StackModifier -> Stack -> IO (Either String Stack)
+runModifier sm s = case runChecks (smTypes sm) s of
+  Just err -> return $ Left $ smName sm ++ ": " ++ err
+  Nothing  -> Right <$> smFunc sm s
+
+applyIntrinsic :: Intrinsic -> Machine -> IO Machine
+applyIntrinsic i m = do
+  res <- runModifier sm (stack m)
+  case res of
+    Left err -> hcf m err
+    Right s' -> return m{ stack=s' }
+  where
+    sm = case i of
+      I_DUMP        -> dump
+      I_DROP        -> drop'
+      I_SWAP        -> swap
+      I_DUP         -> dup
+      I_OVER        -> over
+      I_ROT         -> rot
+      I_PLUS        -> plus
+      I_MINUS       -> minus
+      I_TIMES       -> times
+      I_DIVMOD      -> divMod'
+      I_NOT         -> not'
+      I_AND         -> and'
+      I_OR          -> or'
+      I_XOR         -> xor
+      I_EQUAL       -> equal
+      I_LESSTHAN    -> lessThan
+      I_GREATERTHAN -> greaterThan
+
+applyOperation :: Machine -> Operation -> IO Machine
+-- take no action if a previous step failed
+applyOperation m@Machine{ ok=False } _   = return m
+applyOperation m (OpPushData x)          = return $ pushData m x
+applyOperation m (OpIntrinsic i)         = applyIntrinsic i m
+
+applyLinear :: Machine -> [Operation] -> IO Machine
+applyLinear = foldlM applyOperation
+
+applyIf :: [Block] -> [Block] -> Machine -> IO Machine
+applyIf _ _ m@Machine{ ok=False } = return m
+applyIf c b m                     = do
+  m' <- evalBlocks c m
+  case m' of
+    Machine{ ok=False }                 -> return m'
+    Machine{ stack=[] }                 -> hcf m' "IF: stack underflow"
+    Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
+    Machine{ stack=StackBool True:xs }  -> evalBlocks b m'{ stack=xs }
+    Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
+
+applyIfElse :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine
+applyIfElse _ _ _ m@Machine{ ok=False } = return m
+applyIfElse c b1 b2 m                   = do
+  m' <- evalBlocks c m
+  case m' of
+    Machine{ ok=False }                 -> return m'
+    Machine{ stack=[] }                 -> hcf m' "IFELSE: stack underflow"
+    Machine{ stack=StackBool True:xs }  -> evalBlocks b1 m'{ stack=xs }
+    Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs }
+    Machine{ stack=_:_ }                -> hcf m' "IF: type mis-match"
+
+applyWhile :: [Block] -> [Block] -> Machine -> IO Machine
+applyWhile _ _ m@Machine{ ok=False } = return m
+applyWhile c b m                     = do
+  m' <- evalBlocks c m
+  case m' of
+    Machine{ ok=False }                 -> return m'
+    Machine{ stack=[] }                 -> hcf m' "WHILE: stack underflow"
+    Machine{ stack=StackBool False:xs } -> return m'{ stack=xs }
+    Machine{ stack=StackBool True:xs }  -> do
+      m'' <- evalBlocks b m'{ stack=xs }
+      applyWhile c b m''
+    Machine{ stack=_:_ }                -> hcf m' "WHILE: type mis-match"
+
+evalBlocks :: [Block] -> Machine -> IO Machine
+evalBlocks _ m@Machine{ ok=False } = return m
+evalBlocks [] m                    = return m
+evalBlocks (BLinear b:bs) m        = applyLinear m b >>= evalBlocks bs
+evalBlocks (BIf c b:bs) m          = applyIf c b m >>= evalBlocks bs
+evalBlocks (BIfElse c b1 b2:bs) m  = applyIfElse c b1 b2 m >>= evalBlocks bs
+evalBlocks (BWhile c b:bs) m       = applyWhile c b m >>= evalBlocks bs
+
+interpret :: Program -> IO ()
+interpret p = evalBlocks p newMachine >> return ()
+