diff options
| -rw-r--r-- | DSL.hs | 121 |
1 files changed, 92 insertions, 29 deletions
@@ -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 |