Able to parse simple operations

1 files changed, 120 insertions, 0 deletions

diff --git a/DSL.hs b/DSL.hs
new file mode 100644
index 0000000..ca1fa48
--- /dev/null
+++ b/DSL.hs
@@ -0,0 +1,120 @@
+module DSL where
+
+import Data.Char (isDigit, isSpace)
+
+import Parsers
+
+------------------------------------------------------------------------------
+-- Data types / instances
+------------------------------------------------------------------------------
+
+data StackData
+  = StackInt Integer
+  | StackBool Bool
+
+instance Show StackData where
+  show (StackInt x)      = show x
+  show (StackBool True)  = "true"
+  show (StackBool False) = "false"
+
+type Stack = [StackData]
+
+data Intrinsic
+  = I_DUMP
+    deriving (Show, Eq)
+
+data Operation
+  = OpPushData StackData
+  | OpIntrinsic Intrinsic
+    deriving (Show)
+
+type Program = [Operation]
+
+data TokenData
+  = T_WHITESPACE
+  | 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
+                  }
+
+intrinsicL :: String -> Intrinsic -> DSLLexer
+intrinsicL s i = buildDSLLexer (list s) (const $ T_INTRINSIC i)
+
+wsL :: DSLLexer
+wsL = buildDSLLexer (mult1 $ satisfy isSpace) (const T_WHITESPACE)
+
+intLiteralL :: DSLLexer
+intLiteralL = buildDSLLexer (mult1 $ satisfy isDigit) (T_INT_LITERAL . read)
+
+mainLexer :: Parser Char [DSLToken]
+mainLexer = phrase $ mult1 $ firstOf subLexers
+  where
+    subLexers = [wsL] ++ literals ++ intrinsics
+    literals = [ intLiteralL
+               ]
+    intrinsics = map (uncurry intrinsicL) [ (".", I_DUMP)
+                                          ]
+------------------------------------------------------------------------------
+-- Parsing
+------------------------------------------------------------------------------
+
+wsP :: DSLParser ()
+wsP = do
+  t <- anyToken
+  case tData t of
+    T_WHITESPACE -> result ()
+    _            -> flunk
+
+dataLiteralP :: DSLParser StackData
+dataLiteralP = do
+  t <- anyToken
+  case tData t of
+    T_INT_LITERAL x -> result $ StackInt 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
+                     ]
+
+programP :: DSLParser Program
+programP = do
+  optional wsP
+  ops <- operationP `sepBy1` wsP
+  optional wsP
+  eof
+  return ops
+
+stringToProgram :: String -> Maybe Program
+stringToProgram str = do
+  (_, tokens)  <- parse mainLexer str
+  (_, program) <- parse programP tokens
+  return program
+