Refactor: more robust intrinsics with type-checking

1 files changed, 92 insertions, 29 deletions

diff --git a/DSL.hs b/DSL.hs
index 2b3b5a1..e608bbe 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -18,6 +18,8 @@ instance Show StackData where
   show (StackBool True)  = "true"
   show (StackBool False) = "false"
 
+type TypeCheck = StackData -> Bool
+
 type Stack = [StackData]
 
 data Intrinsic
@@ -37,6 +39,11 @@ data Operation
   | OpIntrinsic Intrinsic
     deriving (Show)
 
+data StackModifier = StackModifier { smName :: String
+                                   , smTypes :: [TypeCheck]
+                                   , smFunc :: Stack -> IO Stack
+                                   }
+
 type Program = [Operation]
 
 data Machine = Machine { ok :: Bool
@@ -139,37 +146,78 @@ stringToProgram str = do
   return program
 
 ------------------------------------------------------------------------------
+-- Type checking
+------------------------------------------------------------------------------
+
+tAny :: TypeCheck
+tAny = const True
+
+tBool :: TypeCheck
+tBool (StackBool _) = True
+tBool _             = False
+
+tInt :: TypeCheck
+tInt (StackInt _) = True
+tInt _            = False
+
+runChecks :: [TypeCheck] -> Stack -> Maybe String
+runChecks fs s
+  | length fs > length s        = Just "stack underflow"
+  | not (and $ zipWith id fs s) = Just "type mis-match"
+  | otherwise                   = Nothing
+
+------------------------------------------------------------------------------
 -- Intrinsics
 ------------------------------------------------------------------------------
 
-dump :: Machine -> IO Machine
-dump m@Machine{ stack=x:xs } = putStrLn (show x) >> return m{ stack=xs }
-dump m                       = hcf m "DUMP: stack underflow"
+dump :: StackModifier
+dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny]
+    f (x:xs) = putStrLn (show x) >> return xs
+    f _      = unreachable
 
-drop' :: Machine -> IO Machine
-drop' m@Machine{ stack=_:xs } = return m{ stack=xs }
-drop' m                       = hcf m "DROP: stack underflow"
+drop' :: StackModifier
+drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny]
+    f (_:xs) = return xs
+    f _      = unreachable
 
-swap :: Machine -> IO Machine
-swap m@Machine{ stack=x:y:xs } = return m{ stack=y:x:xs }
-swap m                         = hcf m "SWAP: stack underflow"
+swap :: StackModifier
+swap = StackModifier { smName="SWAP", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny, tAny]
+    f (x:y:xs) = return $ y:x:xs
+    f _        = unreachable
 
-dup :: Machine -> IO Machine
-dup m@Machine{ stack=x:xs } = return m{ stack=x:x:xs }
-dup m                       = hcf m "DUP: stack underflow"
+dup :: StackModifier
+dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny]
+    f (x:xs) = return $ x:x:xs
+    f _      = unreachable
 
-over :: Machine -> IO Machine
-over m@Machine{ stack=x:y:xs } = return m{ stack=y:x:y:xs }
-over m                         = hcf m "OVER: stack underflow"
+over :: StackModifier
+over = StackModifier { smName="OVER", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny, tAny]
+    f (x:y:xs) = return $ y:x:y:xs
+    f _        = unreachable
 
-rot :: Machine -> IO Machine
-rot m@Machine{ stack=x:y:z:xs } = return m{ stack=y:z:x:xs }
-rot m                           = hcf m "ROT: stack underflow"
+rot :: StackModifier
+rot = StackModifier { smName="ROT", smTypes=ts, smFunc=f }
+  where
+    ts = [tAny, tAny, tAny]
+    f (x:y:z:xs) = return $ y:z:x:xs
+    f _          = unreachable
 
-plus :: Machine -> IO Machine
-plus m@Machine{ stack=StackInt x:StackInt y:xs } = return m{ stack=StackInt (x + y):xs }
-plus m@Machine{ stack=_:_:_ }                    = hcf m "PLUS: type mis-match"
-plus m                                           = hcf m "PLUS: stack underflow"
+plus :: StackModifier
+plus = StackModifier { smName="PLUS", smTypes=ts, smFunc=f }
+  where
+    ts = [tInt, tInt]
+    f (StackInt x:StackInt y:xs) = return $ StackInt (x+y):xs
+    f _                          = unreachable
 
 ------------------------------------------------------------------------------
 -- Core operations
@@ -179,17 +227,32 @@ plus m                                           = hcf m "PLUS: stack underflow"
 hcf :: Machine -> String -> IO Machine
 hcf m msg = putStrLn msg >> return m{ ok=False }
 
+unreachable :: a
+unreachable = error "this branch should be unreachable"
+
 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_DUMP = dump
-applyIntrinsic I_DROP = drop'
-applyIntrinsic I_SWAP = swap
-applyIntrinsic I_DUP  = dup
-applyIntrinsic I_OVER = over
-applyIntrinsic I_ROT  = rot
-applyIntrinsic I_PLUS = plus
+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
 
 ------------------------------------------------------------------------------
 -- Interpretation