StackModifiers now use Void

4 files changed, 19 insertions, 16 deletions

diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs
index 82a8ef2..34137a9 100644
--- a/DSL/Interpretation.hs
+++ b/DSL/Interpretation.hs
@@ -1,7 +1,9 @@
 module DSL.Interpretation where
 
 import qualified Data.Map.Strict as M
+import Data.Bifunctor (first)
 import Data.Foldable (foldlM)
+import Data.Void
 
 import DSL.Types
 import DSL.Util
@@ -20,7 +22,7 @@ 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
+  Nothing  -> first absurd <$> smFunc sm s
 
 applyIntrinsic :: Intrinsic -> Machine -> IO Machine
 applyIntrinsic i m = do
diff --git a/DSL/Intrinsics.hs b/DSL/Intrinsics.hs
index ecb0fad..930a8a0 100644
--- a/DSL/Intrinsics.hs
+++ b/DSL/Intrinsics.hs
@@ -7,7 +7,7 @@ dump :: StackModifier
 dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f }
   where
     ts = [tAny]
-    f (x:xs) = putStrLn x' >> return xs
+    f (x:xs) = putStrLn x' >> return (Right $ xs)
       where
         x' = case x of
           StackString s -> s
@@ -18,42 +18,42 @@ drop' :: StackModifier
 drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f }
   where
     ts = [tAny]
-    f (_:xs) = return xs
+    f (_:xs) = return $ Right xs
     f _      = unreachable
 
 swap :: StackModifier
 swap = StackModifier { smName="SWAP", smTypes=ts, smFunc=f }
   where
     ts = [tAny, tAny]
-    f (x:y:xs) = return $ y:x:xs
+    f (x:y:xs) = return $ Right $ y:x:xs
     f _        = unreachable
 
 dup :: StackModifier
 dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f }
   where
     ts = [tAny]
-    f (x:xs) = return $ x:x:xs
+    f (x:xs) = return $ Right $ x:x:xs
     f _      = unreachable
 
 over :: StackModifier
 over = StackModifier { smName="OVER", smTypes=ts, smFunc=f }
   where
     ts = [tAny, tAny]
-    f (x:y:xs) = return $ y:x:y:xs
+    f (x:y:xs) = return $ Right $ y:x:y:xs
     f _        = unreachable
 
 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 (x:y:z:xs) = return $ Right $ y:z:x:xs
     f _          = unreachable
 
 binArithmetic :: String -> (Integer -> Integer -> [Integer]) -> StackModifier
 binArithmetic name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
   where
     ts = [tInt, tInt]
-    f' (StackInt x:StackInt y:xs) = return $ (StackInt <$> f x y) ++ xs
+    f' (StackInt x:StackInt y:xs) = return $ Right $ (StackInt <$> f x y) ++ xs
     f' _                          = unreachable
 
 plus :: StackModifier
@@ -72,14 +72,14 @@ not' :: StackModifier
 not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f }
   where
     ts = [tBool]
-    f (StackBool x:xs) = return $ StackBool (not x):xs
+    f (StackBool x:xs) = return $ Right $ StackBool (not x):xs
     f _                = unreachable
 
 binBoolean :: String -> (Bool -> Bool -> [Bool]) -> StackModifier
 binBoolean name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
   where
     ts = [tBool, tBool]
-    f' (StackBool x:StackBool y:xs) = return $ (StackBool <$> f x y) ++ xs
+    f' (StackBool x:StackBool y:xs) = return $ Right $ (StackBool <$> f x y) ++ xs
     f' _                            = unreachable
 
 and' :: StackModifier
@@ -95,27 +95,27 @@ strcat :: StackModifier
 strcat = StackModifier { smName="STRCAT", smTypes=ts, smFunc=f }
   where
     ts = [tString, tString]
-    f (StackString x:StackString y:xs) = return $ StackString (x ++ y):xs
+    f (StackString x:StackString y:xs) = return $ Right $ StackString (x ++ y):xs
     f _                                = unreachable
 
 equal :: StackModifier
 equal = StackModifier { smName="EQUAL", smTypes=ts, smFunc=f }
   where
     ts = [tAny, tAny]
-    f (x:y:xs) = return $ StackBool (x == y):xs
+    f (x:y:xs) = return $ Right $ StackBool (x == y):xs
     f _        = unreachable
 
 lessThan :: StackModifier
 lessThan = StackModifier { smName="LESSTHAN", smTypes=ts, smFunc=f }
   where
     ts = [tInt, tInt]
-    f (StackInt x:StackInt y:xs) = return $ StackBool(x < y):xs
+    f (StackInt x:StackInt y:xs) = return $ Right $ StackBool(x < y):xs
     f _                          = unreachable
 
 greaterThan :: StackModifier
 greaterThan = StackModifier { smName="GREATERTHAN", smTypes=ts, smFunc=f }
   where
     ts = [tInt, tInt]
-    f (StackInt x:StackInt y:xs) = return $ StackBool(x > y):xs
+    f (StackInt x:StackInt y:xs) = return $ Right $ StackBool(x > y):xs
     f _                          = unreachable
 
diff --git a/DSL/Types.hs b/DSL/Types.hs
index bcbe7a6..2faacc4 100644
--- a/DSL/Types.hs
+++ b/DSL/Types.hs
@@ -1,6 +1,7 @@
 module DSL.Types where
 
 import Data.Map.Strict (Map)
+import Data.Void
 
 import DSL.BaseParsers (Parser(..))
 
@@ -56,7 +57,7 @@ data Operation
 
 data StackModifier = StackModifier { smName :: String
                                    , smTypes :: [TypeCheck]
-                                   , smFunc :: Stack -> IO Stack
+                                   , smFunc :: Stack -> IO (Either Void Stack)
                                    }
 
 data Block
diff --git a/DSL/Util.hs b/DSL/Util.hs
index 44d272c..6affe75 100644
--- a/DSL/Util.hs
+++ b/DSL/Util.hs
@@ -45,5 +45,5 @@ buildProcTable :: [ProcSpec] -> Either String ProcTable
 buildProcTable ps = appendProcTable ps empty
 
 unreachable :: a
-unreachable = error "this branch should be unreachable"
+unreachable = error "This branch should be unreachable. If you can read this, something has gone EXTREMELY  wrong."