Big file-structure refactor

6 files changed, 606 insertions, 0 deletions

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"
+