Proctables are now maps

5 files changed, 41 insertions, 10 deletions

diff --git a/DSL/Interpretation.hs b/DSL/Interpretation.hs
index e68b64f..37165c3 100644
--- a/DSL/Interpretation.hs
+++ b/DSL/Interpretation.hs
@@ -1,5 +1,6 @@
 module DSL.Interpretation where
 
+import qualified Data.Map.Strict as M
 import Data.Foldable (foldlM)
 
 import DSL.Types
@@ -8,7 +9,7 @@ import DSL.Intrinsics
 import DSL.StdLib (stdlib)
 
 newMachine :: Machine
-newMachine = Machine { ok=True, stack=[], pTable=[] }
+newMachine = Machine { ok=True, stack=[], pTable=M.empty }
 
 pushData :: Machine -> StackData -> Machine
 pushData m@Machine{ stack=xs } x = m{ stack=x:xs }
@@ -47,7 +48,7 @@ applyIntrinsic i m = do
 
 applyCall :: ProcName -> Machine -> IO Machine
 applyCall _ m@Machine{ ok=False } = return m
-applyCall name m@Machine{ pTable=t } = case lookup name t of
+applyCall name m@Machine{ pTable=t } = case M.lookup name t of
   Nothing -> hcf m $ "PROCCALL: undefined proc: " ++ name
   Just bs -> evalBlocks bs m
 
@@ -92,6 +93,8 @@ evalBlocks (BLinear b:bs) m        = applyLinear m b >>= evalBlocks bs
 evalBlocks (BIf c t f:bs) m        = applyIf c t f m >>= evalBlocks bs
 evalBlocks (BWhile c b:bs) m       = applyWhile c b m >>= evalBlocks bs
 
-interpret :: ([ProcSpec], Program) -> IO ()
-interpret (t, p) = evalBlocks p newMachine{ pTable=stdlib++t } >> return ()
+interpret :: (ProcTable, Program) -> IO ()
+interpret (t, p) = case mergeProcTables stdlib t of
+  Just t' -> () <$ evalBlocks p newMachine{ pTable=t' }
+  Nothing -> putStrLn "Failed to include stdlib, duplicate proc definition?"
 
diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs
index e0017bb..72d6b23 100644
--- a/DSL/Parsing.hs
+++ b/DSL/Parsing.hs
@@ -1,9 +1,9 @@
 module DSL.Parsing where
 
 import Data.Char (isDigit, isSpace)
-import Data.Maybe (fromMaybe)
 
 import DSL.Types
+import DSL.Util
 import DSL.BaseParsers
 
 buildDSLLexer :: Parser Char [Char] -> TokenTag -> DSLLexer
@@ -197,6 +197,10 @@ programP = phrase $ procs `plus` code
     procs = mult procP
     code  = mult1 blockP
 
-stringToProgram :: String -> Maybe ([ProcSpec], Program)
-stringToProgram = fmap snd . parse (tokenizer `chain` programP)
+stringToProgram :: String -> Maybe (ProcTable, Program)
+stringToProgram = (>>=(f . snd)) . parse (tokenizer `chain` programP)
+  where
+    f (ps, b) = case buildProcTable ps of
+      Nothing -> Nothing
+      Just t  -> Just (t, b)
 
diff --git a/DSL/StdLib.hs b/DSL/StdLib.hs
index 6483433..360e139 100644
--- a/DSL/StdLib.hs
+++ b/DSL/StdLib.hs
@@ -1,16 +1,18 @@
 module DSL.StdLib (stdlib) where
 
+import Data.Map.Strict (fromList)
+
 import DSL.Types
 import DSL.BaseParsers (parse, mult, chain)
 import DSL.Parsing (tokenizer, procP)
 
-stdlib :: [ProcSpec]
+stdlib :: ProcTable
 stdlib = procs
   where
     p = tokenizer `chain` mult procP
     procs = case parse p (unlines sources) of
       Nothing      -> error "Failed to parse standard library"
-      Just (_, ps) -> ps
+      Just (_, ps) -> fromList ps
 
 sources :: [String]
 sources = [ div'
diff --git a/DSL/Types.hs b/DSL/Types.hs
index 431a361..7467bfd 100644
--- a/DSL/Types.hs
+++ b/DSL/Types.hs
@@ -1,5 +1,7 @@
 module DSL.Types where
 
+import Data.Map.Strict (Map(..))
+
 import DSL.BaseParsers (Parser(..))
 
 data StackData
@@ -65,11 +67,13 @@ data Block
 
 type ProcSpec = (ProcName, [Block])
 
+type ProcTable = Map ProcName [Block]
+
 type Program = [Block]
 
 data Machine = Machine { ok :: Bool
                        , stack :: Stack
-                       , pTable :: [(ProcName, [Block])]
+                       , pTable :: ProcTable
                        }
 
 data TokenTag
diff --git a/DSL/Util.hs b/DSL/Util.hs
index 7767b4b..75d38af 100644
--- a/DSL/Util.hs
+++ b/DSL/Util.hs
@@ -1,5 +1,7 @@
 module DSL.Util where
 
+import Data.Map.Strict (empty, member, insert, toList)
+
 import DSL.Types
 
 tAny :: TypeCheck
@@ -26,6 +28,22 @@ runChecks fs s
 hcf :: Machine -> String -> IO Machine
 hcf m msg = putStrLn msg >> return m{ ok=False }
 
+appendProcTable :: [ProcSpec] -> ProcTable -> Maybe ProcTable
+appendProcTable x y = go x
+  where
+    go []           = Just y
+    go ((n, bs):ps) = go ps >>= f
+      where
+        f acc
+          | member n acc = Nothing
+          | otherwise    = Just $ insert n bs acc
+
+mergeProcTables :: ProcTable -> ProcTable -> Maybe ProcTable
+mergeProcTables x = appendProcTable $ toList x
+
+buildProcTable :: [ProcSpec] -> Maybe ProcTable
+buildProcTable ps = appendProcTable ps empty
+
 unreachable :: a
 unreachable = error "this branch should be unreachable"