diff options
| -rw-r--r-- | DSL.hs | 472 | ||||
| -rw-r--r-- | DSL/BaseParsers.hs | 139 | ||||
| -rw-r--r-- | DSL/Interpretation.hs | 100 | ||||
| -rw-r--r-- | DSL/Intrinsics.hs | 110 | ||||
| -rw-r--r-- | DSL/Parsing.hs | 146 | ||||
| -rw-r--r-- | DSL/Types.hs | 84 | ||||
| -rw-r--r-- | DSL/Util.hs | 27 |
7 files changed, 610 insertions, 468 deletions
@@ -1,473 +1,9 @@ module DSL where -import Data.Char (isDigit, isSpace) -import Data.Foldable (foldlM) - -import Parsers - ------------------------------------------------------------------------------- --- Data types / instances ------------------------------------------------------------------------------- - -data StackData - = StackInt Integer - | StackBool Bool - deriving (Eq) - -instance Show StackData where - show (StackInt x) = show x - show (StackBool True) = "true" - show (StackBool False) = "false" - -type TypeCheck = StackData -> Bool - -type Stack = [StackData] - -data Intrinsic - -- core stack operations - = I_DUMP - | I_DROP - | I_SWAP - | I_DUP - | I_OVER - | I_ROT - -- core arithmetic operations - | I_PLUS - | I_MINUS - | I_TIMES - | I_DIVMOD - -- core boolean operations - | I_NOT - | I_AND - | I_OR - | I_XOR - -- core logical operations - | I_EQUAL - | I_LESSTHAN - | I_GREATERTHAN - deriving (Show, Eq) - -data Operation - = OpPushData StackData - | OpIntrinsic Intrinsic - deriving (Show) - -data StackModifier = StackModifier { smName :: String - , smTypes :: [TypeCheck] - , smFunc :: Stack -> IO Stack - } - -data Block - = BLinear [Operation] - | BIf [Block] [Block] - | BIfElse [Block] [Block] [Block] - | BWhile [Block] [Block] - deriving (Show) - -type Program = [Block] - -data Machine = Machine { ok :: Bool - , stack :: Stack - } - -data TokenData - = T_WHITESPACE - | T_IF - | T_ELSE - | T_WHILE - | T_DO - | T_END - | T_BOOL_LITERAL Bool - | T_INT_LITERAL Integer - | T_INTRINSIC Intrinsic - deriving (Show, Eq) - -data DSLToken = DSLToken { tStr :: String -- original text - , tData :: TokenData -- actual data - } deriving (Show) - -type DSLLexer = Parser Char DSLToken -type DSLParser = Parser DSLToken - ------------------------------------------------------------------------------- --- Lexing ------------------------------------------------------------------------------- - -buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer -buildDSLLexer p f = do - str <- p - return DSLToken { tStr=str - , tData=f str - } - -keywordL :: String -> TokenData -> DSLLexer -keywordL s d = buildDSLLexer (list s) (const d) - -intrinsicL :: String -> Intrinsic -> DSLLexer -intrinsicL s i = keywordL s $ T_INTRINSIC i - -wsL :: DSLLexer -wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE) - -boolLiteralL :: DSLLexer -boolLiteralL = t `alt` f - where - t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True) - f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False) - -intLiteralL :: DSLLexer -intLiteralL = buildDSLLexer go (T_INT_LITERAL . read) - where - go = do - sign <- optional $ token '-' - digits <- mult1 $ satisfy isDigit - result $ maybe digits (:digits) sign - -mainLexer :: Parser Char [DSLToken] -mainLexer = phrase $ mult1 $ firstOf subLexers - where - subLexers = [wsL] - ++ keywords - ++ literals - ++ intrinsics - keywords = map (uncurry keywordL) [ ("IF", T_IF) - , ("ELSE", T_ELSE) - , ("WHILE", T_WHILE) - , ("DO", T_DO) - , ("END", T_END) - ] - literals = [ boolLiteralL - , intLiteralL - ] - intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP) - , ("DROP", I_DROP) - , ("SWAP", I_SWAP) - , ("DUP", I_DUP) - , ("OVER", I_OVER) - , ("ROT", I_ROT) - , ("+", I_PLUS) - , ("-", I_MINUS) - , ("*", I_TIMES) - , ("/%", I_DIVMOD) - , ("!", I_NOT) - , ("&&", I_AND) - , ("||", I_OR) - , ("^", I_XOR) - , ("==", I_EQUAL) - , ("<", I_LESSTHAN) - , (">", I_GREATERTHAN) - ] - -stripWhitespace :: [DSLToken] -> [DSLToken] -stripWhitespace = filter $ not . (==T_WHITESPACE) . tData - ------------------------------------------------------------------------------- --- Parsing ------------------------------------------------------------------------------- - -tokenDataP :: TokenData -> DSLParser DSLToken -tokenDataP t = satisfy $ (==t) . tData - -wsP :: DSLParser () -wsP = () <$ tokenDataP T_WHITESPACE - -dataLiteralP :: DSLParser StackData -dataLiteralP = do - t <- anyToken - case tData t of - T_INT_LITERAL x -> result $ StackInt x - T_BOOL_LITERAL x -> result $ StackBool x - _ -> flunk - -pushDataP :: DSLParser Operation -pushDataP = OpPushData <$> dataLiteralP - -intrinsicP :: DSLParser Operation -intrinsicP = do - t <- anyToken - case tData t of - T_INTRINSIC i -> result $ OpIntrinsic i - _ -> flunk - -operationP :: DSLParser Operation -operationP = firstOf [ pushDataP - , intrinsicP - ] - -linearP :: DSLParser Block -linearP = BLinear <$> mult1 operationP - -ifP :: DSLParser Block -ifP = do - c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO - b <- mult blockP <* tokenDataP T_END - return $ BIf c b - -ifElseP :: DSLParser Block -ifElseP = do - c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO - b1 <- mult blockP <* tokenDataP T_ELSE - b2 <- mult blockP <* tokenDataP T_END - return $ BIfElse c b1 b2 - -whileP :: DSLParser Block -whileP = do - c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO - b <- mult blockP <* tokenDataP T_END - return $ BWhile c b - -blockP :: DSLParser Block -blockP = firstOf [ whileP - , ifElseP - , ifP - , linearP - ] - -programP :: DSLParser Program -programP = phrase $ mult1 blockP - -stringToProgram :: String -> Maybe Program -stringToProgram str = do - (_, tokens) <- parse mainLexer str - (_, program) <- parse programP $ stripWhitespace tokens - 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 :: StackModifier -dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f } - where - ts = [tAny] - f (x:xs) = putStrLn (show x) >> return xs - f _ = unreachable - -drop' :: StackModifier -drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f } - where - ts = [tAny] - f (_:xs) = return 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 _ = unreachable - -dup :: StackModifier -dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f } - where - ts = [tAny] - f (x:xs) = return $ 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 _ = 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 _ = 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' _ = unreachable - -plus :: StackModifier -plus = binArithmetic "PLUS" $ \ x y -> [x + y] - -minus :: StackModifier -minus = binArithmetic "MINUS" $ \ x y -> [x - y] - -times :: StackModifier -times = binArithmetic "TIMES" $ \ x y -> [x * y] - -divMod' :: StackModifier -divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y] - -not' :: StackModifier -not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f } - where - ts = [tBool] - f (StackBool x:xs) = return $ 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' _ = unreachable - -and' :: StackModifier -and' = binBoolean "AND" $ \ x y -> [x && y] - -or' :: StackModifier -or' = binBoolean "OR" $ \ x y -> [x || y] - -xor :: StackModifier -xor = binBoolean "XOR" $ \ x y -> [x /= y] - -equal :: StackModifier -equal = StackModifier { smName="EQUAL", smTypes=ts, smFunc=f } - where - ts = [tAny, tAny] - f (x:y:xs) = return $ 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 _ = 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 _ = unreachable - ------------------------------------------------------------------------------- --- Core operations ------------------------------------------------------------------------------- - --- "halt and catch fire" -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 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 - I_MINUS -> minus - I_TIMES -> times - I_DIVMOD -> divMod' - I_NOT -> not' - I_AND -> and' - I_OR -> or' - I_XOR -> xor - I_EQUAL -> equal - I_LESSTHAN -> lessThan - I_GREATERTHAN -> greaterThan - ------------------------------------------------------------------------------- --- 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 i m - -applyLinear :: Machine -> [Operation] -> IO Machine -applyLinear = foldlM applyOperation - -applyIf :: [Block] -> [Block] -> Machine -> IO Machine -applyIf _ _ m@Machine{ ok=False } = return m -applyIf c b m = do - m' <- evalBlocks c m - case m' of - Machine{ ok=False } -> return m' - Machine{ stack=[] } -> hcf m' "IF: stack underflow" - Machine{ stack=StackBool False:xs } -> return m'{ stack=xs } - Machine{ stack=StackBool True:xs } -> evalBlocks b m'{ stack=xs } - Machine{ stack=_:_ } -> hcf m' "IF: type mis-match" - -applyIfElse :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine -applyIfElse _ _ _ m@Machine{ ok=False } = return m -applyIfElse c b1 b2 m = do - m' <- evalBlocks c m - case m' of - Machine{ ok=False } -> return m' - Machine{ stack=[] } -> hcf m' "IFELSE: stack underflow" - Machine{ stack=StackBool True:xs } -> evalBlocks b1 m'{ stack=xs } - Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs } - Machine{ stack=_:_ } -> hcf m' "IF: type mis-match" - -applyWhile :: [Block] -> [Block] -> Machine -> IO Machine -applyWhile _ _ m@Machine{ ok=False } = return m -applyWhile c b m = do - m' <- evalBlocks c m - case m' of - Machine{ ok=False } -> return m' - Machine{ stack=[] } -> hcf m' "WHILE: stack underflow" - Machine{ stack=StackBool False:xs } -> return m'{ stack=xs } - Machine{ stack=StackBool True:xs } -> do - m'' <- evalBlocks b m'{ stack=xs } - applyWhile c b m'' - Machine{ stack=_:_ } -> hcf m' "WHILE: type mis-match" - -evalBlocks :: [Block] -> Machine -> IO Machine -evalBlocks _ m@Machine{ ok=False } = return m -evalBlocks [] m = return m -evalBlocks (BLinear b:bs) m = applyLinear m b >>= evalBlocks bs -evalBlocks (BIf c b:bs) m = applyIf c b m >>= evalBlocks bs -evalBlocks (BIfElse c b1 b2:bs) m = applyIfElse c b1 b2 m >>= evalBlocks bs -evalBlocks (BWhile c b:bs) m = applyWhile c b m >>= evalBlocks bs - -interpret :: Program -> IO () -interpret p = evalBlocks p newMachine >> return () +import DSL.Types +import DSL.Util +import DSL.Parsing +import DSL.Interpretation interpretFromString :: String -> IO () interpretFromString = maybe err interpret . stringToProgram diff --git a/DSL/BaseParsers.hs b/DSL/BaseParsers.hs new file mode 100644 index 0000000..403ca42 --- /dev/null +++ b/DSL/BaseParsers.hs @@ -0,0 +1,139 @@ +module DSL.BaseParsers where + +-- Parsec is for casuals + +import Control.Applicative (Alternative(..), liftA2) +import Control.Monad (MonadPlus(..), guard) +import Data.Maybe (catMaybes) + +newtype Parser t a = + Parser { parse :: [t] -> Maybe ([t], a) } + +instance Semigroup a => Semigroup (Parser t a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Parser t a) where + mempty = pure mempty + +instance Functor (Parser t) where + fmap f (Parser p) = Parser $ fmap (fmap f) . p + +instance Applicative (Parser t) where + pure = result + + p <*> q = Parser $ \ inp -> do + (inp', f) <- parse p inp + parse (f <$> q) inp' + +instance Monad (Parser t) where + return = pure + + p >>= f = Parser $ \ inp -> do + (inp', x) <- parse p inp + parse (f x) inp' + +instance Alternative (Parser t) where + empty = flunk + + (<|>) = alt + +instance MonadPlus (Parser t) + +instance MonadFail (Parser t) where + fail _ = mzero + +----------------------------------------------------------------------------- + +flunk :: Parser t a +flunk = Parser $ \ _ -> Nothing + +result :: a -> Parser t a +result x = Parser $ \ inp -> Just (inp, x) + +peek :: Parser t a -> Parser t a +peek p = Parser $ \ inp -> do + (_, x) <- parse p inp + return (inp, x) + +anyToken :: Parser t t +anyToken = Parser $ \ inp -> case inp of + t:ts -> Just (ts, t) + _ -> Nothing + +eof :: Parser t () +eof = Parser $ \ inp -> case inp of + [] -> Just ([], ()) + _ -> Nothing + +infixl 3 `alt` +alt :: Parser t a -> Parser t a -> Parser t a +alt (Parser p) (Parser q) = Parser $ \ inp -> p inp <|> q inp + +----------------------------------------------------------------------------- + +phrase :: Parser t a -> Parser t a +phrase = (<* eof) + +recover :: a -> Parser t a -> Parser t a +recover x p = p <|> pure x + +optional :: Parser t a -> Parser t (Maybe a) +optional = recover Nothing . fmap Just + +assert :: (a -> Bool) -> Parser t a -> Parser t a +assert f p = do + x <- p + guard $ f x + return x + +satisfy :: (t -> Bool) -> Parser t t +satisfy f = assert f anyToken + +token :: Eq t => t -> Parser t t +token t = satisfy (==t) + +list :: Eq t => [t] -> Parser t [t] +list = traverse token + +mult :: Parser t a -> Parser t [a] +mult = many + +mult1 :: Parser t a -> Parser t [a] +mult1 = some + +exactly :: Int -> Parser t a -> Parser t [a] +exactly i = sequence . replicate i + +atLeast :: Int -> Parser t a -> Parser t [a] +atLeast i p = exactly i p <> mult p + +atMost :: Int -> Parser t a -> Parser t [a] +atMost i = fmap catMaybes . exactly i . optional + +between :: Int -> Int -> Parser t a -> Parser t [a] +between x y p = exactly (min x y) p <> atMost (abs $ x - y) p + +stopAt :: Parser t a -> Parser t [t] +stopAt p = go + where + p' = ([] <$ peek p) + go = p' <|> liftA2 (:) anyToken go + +stopAfter :: Parser t a -> Parser t ([t], a) +stopAfter p = (,) <$> stopAt p <*> p + +stopIf :: Parser t a -> Parser t [t] +stopIf p = stopAt $ () <$ p <|> eof + +firstOf :: [Parser t a] -> Parser t a +firstOf = foldr1 (<|>) + +sepBy1 :: Parser t a -> Parser t b -> Parser t [a] +sepBy1 a b = do + x <- a + xs <- mult $ b >> a + return $ x:xs + +sepBy :: Parser t a -> Parser t b -> Parser t [a] +sepBy a b = sepBy1 a b <|> pure [] + diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs new file mode 100644 index 0000000..a53be8b --- /dev/null +++ b/DSL/Interpretation.hs @@ -0,0 +1,100 @@ +module DSL.Interpretation where + +import Data.Foldable (foldlM) + +import DSL.Types +import DSL.Util +import DSL.Intrinsics + +newMachine :: Machine +newMachine = Machine { ok=True, stack=[] } + +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 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 + I_MINUS -> minus + I_TIMES -> times + I_DIVMOD -> divMod' + I_NOT -> not' + I_AND -> and' + I_OR -> or' + I_XOR -> xor + I_EQUAL -> equal + I_LESSTHAN -> lessThan + I_GREATERTHAN -> greaterThan + +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 i m + +applyLinear :: Machine -> [Operation] -> IO Machine +applyLinear = foldlM applyOperation + +applyIf :: [Block] -> [Block] -> Machine -> IO Machine +applyIf _ _ m@Machine{ ok=False } = return m +applyIf c b m = do + m' <- evalBlocks c m + case m' of + Machine{ ok=False } -> return m' + Machine{ stack=[] } -> hcf m' "IF: stack underflow" + Machine{ stack=StackBool False:xs } -> return m'{ stack=xs } + Machine{ stack=StackBool True:xs } -> evalBlocks b m'{ stack=xs } + Machine{ stack=_:_ } -> hcf m' "IF: type mis-match" + +applyIfElse :: [Block] -> [Block] -> [Block] -> Machine -> IO Machine +applyIfElse _ _ _ m@Machine{ ok=False } = return m +applyIfElse c b1 b2 m = do + m' <- evalBlocks c m + case m' of + Machine{ ok=False } -> return m' + Machine{ stack=[] } -> hcf m' "IFELSE: stack underflow" + Machine{ stack=StackBool True:xs } -> evalBlocks b1 m'{ stack=xs } + Machine{ stack=StackBool False:xs } -> evalBlocks b2 m'{ stack=xs } + Machine{ stack=_:_ } -> hcf m' "IF: type mis-match" + +applyWhile :: [Block] -> [Block] -> Machine -> IO Machine +applyWhile _ _ m@Machine{ ok=False } = return m +applyWhile c b m = do + m' <- evalBlocks c m + case m' of + Machine{ ok=False } -> return m' + Machine{ stack=[] } -> hcf m' "WHILE: stack underflow" + Machine{ stack=StackBool False:xs } -> return m'{ stack=xs } + Machine{ stack=StackBool True:xs } -> do + m'' <- evalBlocks b m'{ stack=xs } + applyWhile c b m'' + Machine{ stack=_:_ } -> hcf m' "WHILE: type mis-match" + +evalBlocks :: [Block] -> Machine -> IO Machine +evalBlocks _ m@Machine{ ok=False } = return m +evalBlocks [] m = return m +evalBlocks (BLinear b:bs) m = applyLinear m b >>= evalBlocks bs +evalBlocks (BIf c b:bs) m = applyIf c b m >>= evalBlocks bs +evalBlocks (BIfElse c b1 b2:bs) m = applyIfElse c b1 b2 m >>= evalBlocks bs +evalBlocks (BWhile c b:bs) m = applyWhile c b m >>= evalBlocks bs + +interpret :: Program -> IO () +interpret p = evalBlocks p newMachine >> return () + diff --git a/DSL/Intrinsics.hs b/DSL/Intrinsics.hs new file mode 100644 index 0000000..11b37f3 --- /dev/null +++ b/DSL/Intrinsics.hs @@ -0,0 +1,110 @@ +module DSL.Intrinsics where + +import DSL.Types +import DSL.Util + +dump :: StackModifier +dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f } + where + ts = [tAny] + f (x:xs) = putStrLn (show x) >> return xs + f _ = unreachable + +drop' :: StackModifier +drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f } + where + ts = [tAny] + f (_:xs) = return 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 _ = unreachable + +dup :: StackModifier +dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f } + where + ts = [tAny] + f (x:xs) = return $ 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 _ = 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 _ = 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' _ = unreachable + +plus :: StackModifier +plus = binArithmetic "PLUS" $ \ x y -> [x + y] + +minus :: StackModifier +minus = binArithmetic "MINUS" $ \ x y -> [x - y] + +times :: StackModifier +times = binArithmetic "TIMES" $ \ x y -> [x * y] + +divMod' :: StackModifier +divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y] + +not' :: StackModifier +not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f } + where + ts = [tBool] + f (StackBool x:xs) = return $ 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' _ = unreachable + +and' :: StackModifier +and' = binBoolean "AND" $ \ x y -> [x && y] + +or' :: StackModifier +or' = binBoolean "OR" $ \ x y -> [x || y] + +xor :: StackModifier +xor = binBoolean "XOR" $ \ x y -> [x /= y] + +equal :: StackModifier +equal = StackModifier { smName="EQUAL", smTypes=ts, smFunc=f } + where + ts = [tAny, tAny] + f (x:y:xs) = return $ 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 _ = 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 _ = unreachable + diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs new file mode 100644 index 0000000..0b07679 --- /dev/null +++ b/DSL/Parsing.hs @@ -0,0 +1,146 @@ +module DSL.Parsing where + +import Data.Char (isDigit, isSpace) + +import DSL.Types +import DSL.BaseParsers + +buildDSLLexer :: (Parser Char [Char]) -> ([Char] -> TokenData) -> DSLLexer +buildDSLLexer p f = do + str <- p + return DSLToken { tStr=str + , tData=f str + } + +keywordL :: String -> TokenData -> DSLLexer +keywordL s d = buildDSLLexer (list s) (const d) + +intrinsicL :: String -> Intrinsic -> DSLLexer +intrinsicL s i = keywordL s $ T_INTRINSIC i + +wsL :: DSLLexer +wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE) + +boolLiteralL :: DSLLexer +boolLiteralL = t `alt` f + where + t = buildDSLLexer (list "true") (const $ T_BOOL_LITERAL True) + f = buildDSLLexer (list "false") (const $ T_BOOL_LITERAL False) + +intLiteralL :: DSLLexer +intLiteralL = buildDSLLexer go (T_INT_LITERAL . read) + where + go = do + sign <- optional $ token '-' + digits <- mult1 $ satisfy isDigit + result $ maybe digits (:digits) sign + +mainLexer :: Parser Char [DSLToken] +mainLexer = phrase $ mult1 $ firstOf subLexers + where + subLexers = [wsL] + ++ keywords + ++ literals + ++ intrinsics + keywords = map (uncurry keywordL) [ ("IF", T_IF) + , ("ELSE", T_ELSE) + , ("WHILE", T_WHILE) + , ("DO", T_DO) + , ("END", T_END) + ] + literals = [ boolLiteralL + , intLiteralL + ] + intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP) + , ("DROP", I_DROP) + , ("SWAP", I_SWAP) + , ("DUP", I_DUP) + , ("OVER", I_OVER) + , ("ROT", I_ROT) + , ("+", I_PLUS) + , ("-", I_MINUS) + , ("*", I_TIMES) + , ("/%", I_DIVMOD) + , ("!", I_NOT) + , ("&&", I_AND) + , ("||", I_OR) + , ("^", I_XOR) + , ("==", I_EQUAL) + , ("<", I_LESSTHAN) + , (">", I_GREATERTHAN) + ] + +stripWhitespace :: [DSLToken] -> [DSLToken] +stripWhitespace = filter $ not . (==T_WHITESPACE) . tData + +------------------------------------------------------------------------------ +-- Parsing +------------------------------------------------------------------------------ + +tokenDataP :: TokenData -> DSLParser DSLToken +tokenDataP t = satisfy $ (==t) . tData + +wsP :: DSLParser () +wsP = () <$ tokenDataP T_WHITESPACE + +dataLiteralP :: DSLParser StackData +dataLiteralP = do + t <- anyToken + case tData t of + T_INT_LITERAL x -> result $ StackInt x + T_BOOL_LITERAL x -> result $ StackBool x + _ -> flunk + +pushDataP :: DSLParser Operation +pushDataP = OpPushData <$> dataLiteralP + +intrinsicP :: DSLParser Operation +intrinsicP = do + t <- anyToken + case tData t of + T_INTRINSIC i -> result $ OpIntrinsic i + _ -> flunk + +operationP :: DSLParser Operation +operationP = firstOf [ pushDataP + , intrinsicP + ] + +linearP :: DSLParser Block +linearP = BLinear <$> mult1 operationP + +ifP :: DSLParser Block +ifP = do + c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO + b <- mult blockP <* tokenDataP T_END + return $ BIf c b + +ifElseP :: DSLParser Block +ifElseP = do + c <- tokenDataP T_IF *> mult blockP <* tokenDataP T_DO + b1 <- mult blockP <* tokenDataP T_ELSE + b2 <- mult blockP <* tokenDataP T_END + return $ BIfElse c b1 b2 + +whileP :: DSLParser Block +whileP = do + c <- tokenDataP T_WHILE *> mult blockP <* tokenDataP T_DO + b <- mult blockP <* tokenDataP T_END + return $ BWhile c b + +blockP :: DSLParser Block +blockP = firstOf [ whileP + , ifElseP + , ifP + , linearP + ] + +programP :: DSLParser Program +programP = phrase $ mult1 blockP + +stringToProgram :: String -> Maybe Program +stringToProgram str = do + (_, tokens) <- parse mainLexer str + (_, program) <- parse programP $ stripWhitespace tokens + return program + diff --git a/DSL/Types.hs b/DSL/Types.hs new file mode 100644 index 0000000..2c33aad --- /dev/null +++ b/DSL/Types.hs @@ -0,0 +1,84 @@ +module DSL.Types where + +import DSL.BaseParsers (Parser(..)) + +data StackData + = StackInt Integer + | StackBool Bool + deriving (Eq) + +instance Show StackData where + show (StackInt x) = show x + show (StackBool True) = "true" + show (StackBool False) = "false" + +type TypeCheck = StackData -> Bool + +type Stack = [StackData] + +data Intrinsic + -- core stack operations + = I_DUMP + | I_DROP + | I_SWAP + | I_DUP + | I_OVER + | I_ROT + -- core arithmetic operations + | I_PLUS + | I_MINUS + | I_TIMES + | I_DIVMOD + -- core boolean operations + | I_NOT + | I_AND + | I_OR + | I_XOR + -- core logical operations + | I_EQUAL + | I_LESSTHAN + | I_GREATERTHAN + deriving (Show, Eq) + +data Operation + = OpPushData StackData + | OpIntrinsic Intrinsic + deriving (Show) + +data StackModifier = StackModifier { smName :: String + , smTypes :: [TypeCheck] + , smFunc :: Stack -> IO Stack + } + +data Block + = BLinear [Operation] + | BIf [Block] [Block] + | BIfElse [Block] [Block] [Block] + | BWhile [Block] [Block] + deriving (Show) + +type Program = [Block] + +data Machine = Machine { ok :: Bool + , stack :: Stack + } + +data TokenData + = T_WHITESPACE + | T_IF + | T_ELSE + | T_WHILE + | T_DO + | T_END + | T_BOOL_LITERAL Bool + | T_INT_LITERAL Integer + | T_INTRINSIC Intrinsic + deriving (Show, Eq) + +data DSLToken = DSLToken { tStr :: String -- original text + , tData :: TokenData -- actual data + } deriving (Show) + +type DSLLexer = Parser Char DSLToken +type DSLParser = Parser DSLToken + diff --git a/DSL/Util.hs b/DSL/Util.hs new file mode 100644 index 0000000..67435a2 --- /dev/null +++ b/DSL/Util.hs @@ -0,0 +1,27 @@ +module DSL.Util where + +import DSL.Types + +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 + +hcf :: Machine -> String -> IO Machine +hcf m msg = putStrLn msg >> return m{ ok=False } + +unreachable :: a +unreachable = error "this branch should be unreachable" + |