Introduce procs

4 files changed, 46 insertions, 8 deletions

diff --git a/DSL/BaseParsers.hs b/DSL/BaseParsers.hs
index b4b5234..4da9c38 100644
--- a/DSL/BaseParsers.hs
+++ b/DSL/BaseParsers.hs
@@ -81,6 +81,9 @@ chain p q = do
 phrase :: Parser t a -> Parser t a
 phrase = (<* eof)
 
+plus :: Parser t a -> Parser t b -> Parser t (a, b)
+plus = liftA2 (,)
+
 recover :: a -> Parser t a -> Parser t a
 recover x p = p <|> pure x
 
diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs
index a53be8b..e02bc74 100644
--- a/DSL/Interpretation.hs
+++ b/DSL/Interpretation.hs
@@ -7,7 +7,7 @@ import DSL.Util
 import DSL.Intrinsics
 
 newMachine :: Machine
-newMachine = Machine { ok=True, stack=[] }
+newMachine = Machine { ok=True, stack=[], pTable=[] }
 
 pushData :: Machine -> StackData -> Machine
 pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
@@ -43,11 +43,18 @@ applyIntrinsic i m = do
       I_LESSTHAN    -> lessThan
       I_GREATERTHAN -> greaterThan
 
+applyCall :: ProcName -> Machine -> IO Machine
+applyCall _ m@Machine{ ok=False } = return m
+applyCall name m@Machine{ pTable=t } = case lookup name t of
+  Nothing -> hcf m $ "PROCCALL: undefined proc: " ++ name
+  Just bs -> evalBlocks bs m
+
 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
+applyOperation m (OpCall name)           = applyCall name m
 
 applyLinear :: Machine -> [Operation] -> IO Machine
 applyLinear = foldlM applyOperation
@@ -95,6 +102,6 @@ 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 ()
+interpret :: ([ProcSpec], Program) -> IO ()
+interpret (t, p) = evalBlocks p newMachine{ pTable=t } >> return ()
 
diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs
index 76acacd..d255c35 100644
--- a/DSL/Parsing.hs
+++ b/DSL/Parsing.hs
@@ -20,7 +20,8 @@ wsL :: DSLLexer
 wsL = buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE
 
 keywordL :: DSLLexer
-keywordL = fromTableL [ ("IF",    T_IF)
+keywordL = fromTableL [ ("PROC",  T_PROC)
+                      , ("IF",    T_IF)
                       , ("ELSE",  T_ELSE)
                       , ("WHILE", T_WHILE)
                       , ("DO",    T_DO)
@@ -53,6 +54,11 @@ literalL = firstOf [ intLiteralL
                    , stringLiteralL
                    ]
 
+identifierL :: DSLLexer
+identifierL = buildDSLLexer go T_IDENTIFIER
+  where
+    go = mult1 $ satisfy $ not . isSpace
+
 intrinsicL :: DSLLexer
 intrinsicL = fromTableL [ (".",    T_INTRINSIC I_DUMP)
                         , ("DROP", T_INTRINSIC I_DROP)
@@ -77,6 +83,7 @@ lexemeL :: DSLLexer
 lexemeL = firstOf [ keywordL
                   , literalL
                   , intrinsicL
+                  , identifierL
                   ]
 
 tokenizer :: Parser Char [Token]
@@ -112,9 +119,13 @@ intrinsicP = do
     T_INTRINSIC i -> result $ OpIntrinsic i
     _             -> flunk
 
+callP :: DSLParser Operation
+callP = OpCall . tStr <$> tagP T_IDENTIFIER
+
 operationP :: DSLParser Operation
 operationP = firstOf [ pushDataP
                      , intrinsicP
+                     , callP
                      ]
 
 linearP :: DSLParser Block
@@ -139,6 +150,12 @@ whileP = do
   b <- mult blockP <* tagP T_END
   return $ BWhile c b
 
+procP :: DSLParser ProcSpec
+procP = front `plus` back
+  where
+    front = tagP T_PROC >> tStr <$> tagP T_IDENTIFIER
+    back  = mult blockP <* tagP T_END
+
 blockP :: DSLParser Block
 blockP = firstOf [ whileP
                  , ifElseP
@@ -146,9 +163,12 @@ blockP = firstOf [ whileP
                  , linearP
                  ]
 
-programP :: DSLParser Program
-programP = phrase $ mult1 blockP
+programP :: DSLParser ([ProcSpec], Program)
+programP = phrase $ procs `plus` code
+  where
+    procs = mult procP
+    code  = mult1 blockP
 
-stringToProgram :: String -> Maybe Program
-stringToProgram = fmap snd . parse (chain tokenizer programP)
+stringToProgram :: String -> Maybe ([ProcSpec], Program)
+stringToProgram = fmap snd . parse (tokenizer `chain` programP)
 
diff --git a/DSL/Types.hs b/DSL/Types.hs
index bb1f862..0a4de3f 100644
--- a/DSL/Types.hs
+++ b/DSL/Types.hs
@@ -42,9 +42,12 @@ data Intrinsic
   | I_GREATERTHAN
     deriving (Show, Eq)
 
+type ProcName = String
+
 data Operation
   = OpPushData StackData
   | OpIntrinsic Intrinsic
+  | OpCall ProcName
     deriving (Show)
 
 data StackModifier = StackModifier { smName :: String
@@ -59,14 +62,18 @@ data Block
   | BWhile [Block] [Block]
     deriving (Show)
 
+type ProcSpec = (ProcName, [Block])
+
 type Program = [Block]
 
 data Machine = Machine { ok :: Bool
                        , stack :: Stack
+                       , pTable :: [(ProcName, [Block])]
                        }
 
 data TokenTag
   = T_WHITESPACE
+  | T_PROC
   | T_IF
   | T_ELSE
   | T_WHILE
@@ -76,6 +83,7 @@ data TokenTag
   | T_BOOL_LITERAL
   | T_STRING_LITERAL
   | T_INTRINSIC Intrinsic
+  | T_IDENTIFIER
     deriving (Show, Eq)
 
 data Token = Token { tStr :: String -- original text