From 7e59323e865f86f1e67821a3ff96efc8e5822dff Mon Sep 17 00:00:00 2001
From: Matthew Hall <hallmatthew314@gmail.com>
Date: Tue, 14 Feb 2023 11:29:11 +1300
Subject: Very basic interpretations

---
 DSL.hs | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 55 insertions(+)

(limited to 'DSL.hs')

diff --git a/DSL.hs b/DSL.hs
index ca1fa48..74259e8 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -1,6 +1,7 @@
 module DSL where
 
 import Data.Char (isDigit, isSpace)
+import Data.Foldable (foldlM)
 
 import Parsers
 
@@ -30,6 +31,10 @@ data Operation
 
 type Program = [Operation]
 
+data Machine = Machine { ok :: Bool
+                       , stack :: Stack
+                       }
+
 data TokenData
   = T_WHITESPACE
   | T_INT_LITERAL Integer
@@ -118,3 +123,53 @@ stringToProgram str = do
   (_, program) <- parse programP tokens
   return program
 
+------------------------------------------------------------------------------
+-- Intrinsics
+------------------------------------------------------------------------------
+
+dump :: Machine -> IO Machine
+dump m = case stack m of
+  []   -> hcf m "DUMP: stack underflow"
+  x:xs -> putStrLn (show x) >> return m{ stack=xs }
+
+------------------------------------------------------------------------------
+-- Core operations
+------------------------------------------------------------------------------
+
+-- "halt and catch fire"
+hcf :: Machine -> String -> IO Machine
+hcf m msg = putStrLn msg >> return m{ ok=False }
+
+pushData :: Machine -> StackData -> Machine
+pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
+
+applyIntrinsic :: Machine -> Intrinsic -> IO Machine
+applyIntrinsic m I_DUMP = dump m
+
+------------------------------------------------------------------------------
+-- Interpretation
+------------------------------------------------------------------------------
+
+newMachine :: Machine
+newMachine = Machine { ok=True, stack=[] }
+
+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 m i
+
+applyLinear :: Machine -> [Operation] -> IO Machine
+applyLinear = foldlM applyOperation
+
+interpret :: Program -> IO ()
+interpret p = applyLinear newMachine p >> return ()
+
+interpretFromString :: String -> IO ()
+interpretFromString = maybe err interpret . stringToProgram
+  where
+    err = putStrLn "Unable to parse program"
+
+interpretFromFile :: FilePath -> IO ()
+interpretFromFile path = readFile path >>= interpretFromString
+
-- 
cgit v1.2.1