diff options
Diffstat (limited to 'DSL/Intrinsics.hs')
| -rw-r--r-- | DSL/Intrinsics.hs | 26 |
1 files changed, 13 insertions, 13 deletions
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 |
