Parsing overhaul (slightly better errors)

1 files changed, 82 insertions, 82 deletions

diff --git a/DSL/Parsing.hs b/DSL/Parsing.hs
index d4d1253..028b738 100644
--- a/DSL/Parsing.hs
+++ b/DSL/Parsing.hs
@@ -18,26 +18,28 @@ fromTableL :: [(String, TokenTag)] -> DSLLexer
 fromTableL table = firstOf $ map (uncurry fromStringL) table
 
 wsL :: DSLLexer
-wsL = buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE
+wsL = prependError "wsL:" $ buildDSLLexer (mult1 $ satisfy isSpace) T_WHITESPACE
 
 commentL :: DSLLexer
-commentL = buildDSLLexer go T_COMMENT
+commentL = prependError "commentL" $ buildDSLLexer go T_COMMENT
   where
     delim = list "'''"
     go = delim *> (fmap fst $ stopAfter delim)
 
 keywordL :: DSLLexer
-keywordL = fromTableL [ ("PROC",  T_PROC)
-                      , ("IF",    T_IF)
-                      , ("ELIF",  T_ELIF)
-                      , ("ELSE",  T_ELSE)
-                      , ("WHILE", T_WHILE)
-                      , ("DO",    T_DO)
-                      , ("END",   T_END)
-                      ]
+keywordL = prependError "keywordL:" $ fromTableL t
+  where
+    t = [ ("PROC",  T_PROC)
+        , ("IF",    T_IF)
+        , ("ELIF",  T_ELIF)
+        , ("ELSE",  T_ELSE)
+        , ("WHILE", T_WHILE)
+        , ("DO",    T_DO)
+        , ("END",   T_END)
+        ]
 
 intLiteralL :: DSLLexer
-intLiteralL = buildDSLLexer go T_INT_LITERAL
+intLiteralL = prependError "intLiteralL:" $ buildDSLLexer go T_INT_LITERAL
   where
     go = do
       sign   <- optionalMaybe $ token '-'
@@ -45,59 +47,65 @@ intLiteralL = buildDSLLexer go T_INT_LITERAL
       result $ maybe digits (:digits) sign
 
 boolLiteralL :: DSLLexer
-boolLiteralL = f "true" `alt` f "false"
+boolLiteralL = prependError "boolLiteralL:" $ f "true" `alt` f "false"
   where
     f s = fromStringL s T_BOOL_LITERAL
 
 stringLiteralL :: DSLLexer
-stringLiteralL = buildDSLLexer go T_STRING_LITERAL
+stringLiteralL = prependError "stringLiteralL:" $ buildDSLLexer go T_STRING_LITERAL
   where
     go = token '"' *> strChars <* token '"'
     strChars = concat <$> mult strChar
     strChar = list ['\\', '"'] `alt` (pure <$> satisfy (/='"'))
 
 literalL :: DSLLexer
-literalL = firstOf [ intLiteralL
-                   , boolLiteralL
-                   , stringLiteralL
-                   ]
+literalL = prependError "literalL:" $ firstOf ps
+  where
+    ps = [ intLiteralL
+         , boolLiteralL
+         , stringLiteralL
+         ]
 
 identifierL :: DSLLexer
-identifierL = buildDSLLexer go T_IDENTIFIER
+identifierL = prependError "identifierL:" $ buildDSLLexer go T_IDENTIFIER
   where
     go = mult1 $ satisfy $ not . isSpace
 
 intrinsicL :: DSLLexer
-intrinsicL = fromTableL [ (".",    T_INTRINSIC I_DUMP)
-                        , ("DROP", T_INTRINSIC I_DROP)
-                        , ("SWAP", T_INTRINSIC I_SWAP)
-                        , ("DUP",  T_INTRINSIC I_DUP)
-                        , ("OVER", T_INTRINSIC I_OVER)
-                        , ("ROT",  T_INTRINSIC I_ROT)
-                        , ("+",    T_INTRINSIC I_PLUS)
-                        , ("-",    T_INTRINSIC I_MINUS)
-                        , ("*",    T_INTRINSIC I_TIMES)
-                        , ("/%",   T_INTRINSIC I_DIVMOD)
-                        , ("!",    T_INTRINSIC I_NOT)
-                        , ("&&",   T_INTRINSIC I_AND)
-                        , ("||",   T_INTRINSIC I_OR)
-                        , ("^",    T_INTRINSIC I_XOR)
-                        , ("++",   T_INTRINSIC I_STRCAT)
-                        , ("==",   T_INTRINSIC I_EQUAL)
-                        , ("<",    T_INTRINSIC I_LESSTHAN)
-                        , (">",    T_INTRINSIC I_GREATERTHAN)
-                        ]
+intrinsicL = prependError "intrinsicL:" $ fromTableL t
+  where
+    t = [ (".",    T_INTRINSIC I_DUMP)
+        , ("DROP", T_INTRINSIC I_DROP)
+        , ("SWAP", T_INTRINSIC I_SWAP)
+        , ("DUP",  T_INTRINSIC I_DUP)
+        , ("OVER", T_INTRINSIC I_OVER)
+        , ("ROT",  T_INTRINSIC I_ROT)
+        , ("+",    T_INTRINSIC I_PLUS)
+        , ("-",    T_INTRINSIC I_MINUS)
+        , ("*",    T_INTRINSIC I_TIMES)
+        , ("/%",   T_INTRINSIC I_DIVMOD)
+        , ("!",    T_INTRINSIC I_NOT)
+        , ("&&",   T_INTRINSIC I_AND)
+        , ("||",   T_INTRINSIC I_OR)
+        , ("^",    T_INTRINSIC I_XOR)
+        , ("++",   T_INTRINSIC I_STRCAT)
+        , ("==",   T_INTRINSIC I_EQUAL)
+        , ("<",    T_INTRINSIC I_LESSTHAN)
+        , (">",    T_INTRINSIC I_GREATERTHAN)
+        ]
 
 lexemeL :: DSLLexer
-lexemeL = firstOf [ commentL
-                  , keywordL
-                  , literalL
-                  , intrinsicL
-                  , identifierL
-                  ]
+lexemeL = prependError "lexemeL:" $ firstOf ls
+  where
+    ls = [ commentL
+         , keywordL
+         , literalL
+         , intrinsicL
+         , identifierL
+         ]
 
 tokenizer :: Parser Char [Token]
-tokenizer = filter f <$> go
+tokenizer = prependError "tokenizer:" $ filter f <$> go
   where
     go = optional wsL *> lexemeL `sepBy` wsL <* optional wsL
     f Token { tTag=t } = t /= T_COMMENT
@@ -107,13 +115,13 @@ tokenizer = filter f <$> go
 ------------------------------------------------------------------------------
 
 tagP :: TokenTag -> DSLParser Token
-tagP t = satisfy $ (==t) . tTag
+tagP t = prependError "tagP:" $ satisfy $ (==t) . tTag
 
 wsP :: DSLParser ()
-wsP = () <$ tagP T_WHITESPACE
+wsP = prependError "wsP:" $ () <$ tagP T_WHITESPACE
 
 dataLiteralP :: DSLParser StackData
-dataLiteralP = do
+dataLiteralP = prependError "dataLiteralP:" $ do
   Token { tTag=t, tStr=s } <- anyToken
   case (t, s) of
     (T_BOOL_LITERAL, "true")  -> result $ StackBool True
@@ -123,29 +131,31 @@ dataLiteralP = do
     _                         -> flunk
 
 pushDataP :: DSLParser Operation
-pushDataP = OpPushData <$> dataLiteralP
+pushDataP = prependError "pushDataP:" $ OpPushData <$> dataLiteralP
 
 intrinsicP :: DSLParser Operation
-intrinsicP = do
+intrinsicP = prependError "intrinsicP:" $ do
   t <- anyToken
   case tTag t of
     T_INTRINSIC i -> result $ OpIntrinsic i
     _             -> flunk
 
 callP :: DSLParser Operation
-callP = OpCall . tStr <$> tagP T_IDENTIFIER
+callP = prependError "callP:" $ OpCall . tStr <$> tagP T_IDENTIFIER
 
 operationP :: DSLParser Operation
-operationP = firstOf [ pushDataP
-                     , intrinsicP
-                     , callP
-                     ]
+operationP = prependError "operationP:" $ firstOf ops
+  where
+    ops = [ pushDataP
+          , intrinsicP
+          , callP
+          ]
 
 linearP :: DSLParser Block
-linearP = BLinear <$> mult1 operationP
+linearP = prependError "linearP:" $ BLinear <$> mult1 operationP
 
 ifP :: DSLParser Block
-ifP = do
+ifP = prependError "ifP:" $ do
   first <- (tagP T_IF *> bp <* tagP T_DO) `plus` bp
   elifs <- mult $ (tagP T_ELIF *> bp <* tagP T_DO) `plus` bp
   elze  <- optionalMaybe $ tagP T_ELSE >> bp
@@ -158,41 +168,31 @@ ifP = do
     elseToPair Nothing   = ([BLinear [OpPushData $ StackBool True]], [])
     elseToPair (Just bs) = ([BLinear [OpPushData $ StackBool True]], bs)
 
---ifP = do
---  c <- tagP T_IF *> mult blockP <* tagP T_DO
---  b <- mult blockP <* tagP T_END
---  return $ BIf c b
-
-{-
-exactly 1: IF   [blocks] DO [blocks]
-0 or many: ELIF [blocks] DO [blocks]
-0 or 1:    ELSE [blocks]
-exactly 1: END
-
-IF c1 DO b1 ELIF c2 DO b2 ELIF c3 DO b3 ELSE b4
--}
-
-
 whileP :: DSLParser Block
-whileP = do
+whileP = prependError "whileP:" $ do
   c <- tagP T_WHILE *> mult blockP <* tagP T_DO
   b <- mult blockP <* tagP T_END
   return $ BWhile c b
 
+blockP :: DSLParser Block
+blockP = prependError "blockP:" $ firstOf bs
+  where
+    bs = [ whileP
+         , ifP
+         , linearP
+         ]
+
 procP :: DSLParser ProcSpec
-procP = front `plus` back
+procP = prependError "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
-                 , ifP
-                 , linearP
-                 ]
+programP :: DSLParser [ProcSpec]
+programP = prependError "programP:" $ phrase $ mult procP
 
-stringToProgram :: String -> Maybe ProcTable
-stringToProgram = (>>=buildProcTable . snd) . parse (tokenizer `chain` program)
-  where
-    program = phrase $ mult procP
+stringToProgram :: String -> Either String ProcTable
+stringToProgram s = case parse (tokenizer `chain` programP) s of
+  Left e       -> Left $ nicePrintParserError e
+  Right (_, x) -> buildProcTable x