Big file-structure refactor

1 files changed, 4 insertions, 468 deletions

diff --git a/DSL.hs b/DSL.hs
index e5589ea..50d8ca3 100644
--- a/DSL.hs
+++ b/DSL.hs
@@ -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