require combinator and supporting change to Parser

src/Parser.hs

@@ -29,12 +29,12 @@ module Parser
 , somewith
 , oneOf
 , apply
-, parse
 , Parser
 , guard
 , failWith
 , guardWith
-, everyWith
+, failure
+, require
 , ParserResult
 , (<|>), (>>=)
 , trim
@@ -47,26 +47,20 @@ import Control.Monad ((>>=), return, ap, liftM, guard)
 import Control.Applicative (Alternative, (<|>), empty, many, some, optional)
 import Prelude hiding (head)
 
-type ParserError = (String, Int, Int)
-type ParserSuccess a = (a, String, Int, Int)
+type ParserError = Maybe (String, Int, Int)
+type ParserSuccess a = (a, String, Int, Int) -- (result, unparsed, line, col, required)
 type ParserResult a = Either ParserError (ParserSuccess a)
 
 newtype Parser a = Parser (String -> Either ParserError (ParserSuccess a))
--- newtype Parser a = Parser (String -> [(a, String)])
 
--- printResult :: ParserResult Either String String
--- printResult
+failure = Left . Just
 
 maybeHead [] = Nothing
 maybeHead (x:_) = Just x
 
 apply :: Parser a -> String -> ParserResult a
 apply (Parser p) s = p s
 
-parse :: Parser a -> String -> ParserResult a
-parse p = apply p
--- parse p = fmap fst . maybeHead . apply p
-
 instance Functor Parser where
   fmap = liftM
 
@@ -78,45 +72,55 @@ none :: Parser [a]
 none = return []
 
 failWith :: String -> Parser a
-failWith msg = Parser (\s->Left (msg, 0, 0))
+failWith msg = Parser (\s->failure (msg, 0, 0))
 
 guardWith :: String -> Bool -> Parser ()
 guardWith msg True = return ()
 guardWith msg False = failWith msg
 
-everyWith msg p = Parser q
-  where q s = res (apply (many p >>= (\r->space >> return r)) s)
-        res (Right (x, "", l, c)) = Right (x, "", l, c)
-        res (Right (x, u, l, c)) = Left (msg, l, c)
-        res error = error
+
+-- everyWith msg p = Parser q
+--   where q s = res (apply (many p >>= (\r->space >> return r)) s)
+--         res (Right (x, "", l, c, r)) = Right (x, "", l, c, r)
+--         res (Right (x, u, l, c, r)) = Left (msg, l, c)
+--         res error = error
 
 
 instance Alternative Parser where
-  empty = Parser (\s -> Left ("", 0, 0))
+  empty = Parser (\s -> Left Nothing)
   p <|> q = Parser f where
-    f s = let ps = apply p s in
-              if null ps then apply q s 
-                         else ps
+    f s = let pick (Left Nothing) = apply q s
+              pick ps@(Right x) = ps
+              pick ps = ps
+          in pick $ apply p s
+    -- f s = let ps = apply p s 
+    --           if first ps then apply q s 
+    --                      else ps
+
+chooseErr Nothing x = x
+chooseErr x _ = x
 
 instance Monad Parser where
   return x = Parser (\s -> Right (x, s, 0, 0))
-  -- p >>= q = Parser (\s -> do (x, s', l', c') <- apply p s
-  --                            (y, s'', l'', c'') <- apply (q x) s'
-  --                            return (y, s'', l'+l'', if l'' > 0 then c'' else c' + c'')
-  --                  )
   p >>= q = Parser outer
     where outer s = res (apply p s)
           res (Right (x, s', l', c')) = inner (apply (q x) s') l' c'
           res (Left error) = Left error
           inner (Right (y, s'', l'', c'')) l' c' = Right (y, s'', l'+l'', if l'' > 0 then c'' else c' + c'')
-          inner (Left (error, l'', c'')) l' c' = Left (error, l'+l'', if l'' > 0 then c'' else c' + c'')
+          inner (Left (Just (error, l'', c''))) l' c' = failure (error, l'+l'', if l'' > 0 then c'' else c' + c'')
+          inner (Left Nothing) l' c' = Left Nothing
 
+require msg p = Parser q
+  where q s = res (apply p s)
+        res (Right (x, s, l, c)) = Right (x, s, l, c) 
+        res (Left Nothing) = failure (msg, 0, 0)
+        res e = e
 
 ifLineSep c t f = if c=='\n' || c=='\r' then t else f
 
 getc :: Parser Char
 getc = Parser f where
-  f [] = Left ("End of input", 0, 0)
+  f [] = Left Nothing
   f (c:cs) = Right (c, cs, ifLineSep c 1 0 , ifLineSep c 0 1)
 
 sat :: (Char -> Bool) -> Parser Char

src/RuleGenerator.hs

@@ -47,7 +47,8 @@ generate source = q tree
     q (Right (tops, unparsed, l, c)) = if length unparsed > 0
                                           then Left ("Could not parse on\n  on " ++ printLoc l c)
                                           else Right . trim . joinLines $ gen <$> tops
-    q (Left (error, l, c)) = Left (error ++ "\n  on " ++ printLoc l c)
+    q (Left (Just (error, l, c))) = Left (error ++ "\n  on " ++ printLoc l c)
+    q (Left Nothing) = Left ("Unexpected parser error.")
 
 funcBlock ind (FuncDef name params body) = concat 
   [ indent ind

src/RuleParser.hs

@@ -105,7 +105,8 @@ readDef def s = case reads s of
 
 _natural :: Parser Int
 _natural = do  -- a natural number
-  str <- many digit
+  str <- some digit
+  guard (str/="")
   let n = readDef (-1) str
   guardWith "expected an integer" (n /= -1)
   return n
@@ -222,11 +223,11 @@ _path :: Parser PathDef
 _path = do
   symbol "match"
   optional $ symbol "/"
-  parts <- token _pathParts
+  parts <- require "expected a path after `match`" $ token _pathParts
   className <- _pathType
-  symbol "{"
+  require "expected a `{`" $ symbol "{"
   body <- many (PathBodyPath <$> _path <|> PathBodyDir <$> _pathDir <|> PathBodyFunc <$> _funcDef)
-  symbol "}"
+  require "expected a closing `}`" $ symbol "}"
   return  $ PathDef parts className body
 
 
@@ -235,8 +236,5 @@ _topLevel = (TopLevelPath <$> _path)
         <|> _topLevelType 
         <|> TopLevelFunc <$> _funcDef
 
--- every :: String -> ParserResult [TopLevel]
-
--- parseRules :: String -> [([TopLevel], String)]
 parseRules :: String -> ParserResult [TopLevel]
-parseRules = apply (everyWith "Expected either a function, path or type definition" _topLevel ) 
+parseRules = apply (many _topLevel ) . trim

src/TSGenerator.hs

@@ -88,13 +88,12 @@ gen tops = result where
   g (TopLevelType name refs) = topLevelType name refs
   g _ = ""
 
+
 generate :: String -> Either String String
 generate s = result $ parseRules s where
-  result (Left (e,l,c)) = Left (e ++ "\n  on " ++printLoc l c) -- $ Error Nothing "Indeterministic nonesense."
+  result (Left Nothing) = Left ("Unexpected parser error.")
+  result (Left (Just (e,l,c))) = Left (e ++ "\n  on " ++printLoc l c)
   result (Right (tops, "", _, _)) = gen tops
-  result (Right (tops, unparsed, l, c)) = Left ("Unexpected input at " ++ printLoc l c)
-  -- result ((tops, ""):_) = gen tops
-  -- result ((_, rem):_) = Left $ Error (loc s rem) "Could not parse"
-  -- printLoc l c = show l ++":"++show c
+  result (Right (tops, unparsed, l, c)) = Left ("Unexpected input on " ++ printLoc l c)
   printLoc l c = "line " ++ show (l+1) ++", column "++show (c+1)
 

test/ParserSpec.hs

@@ -10,87 +10,105 @@ import Parser
 
 with x f = f x
 
+_apply p s = res (apply p s) 
+  where res (Right (x, u, l, c)) = Right (x, u)
+        res (Left x) = Left x
+
+
 main :: IO ()
 main = hspec spec
 
 spec :: Spec
 spec = do
   describe "getc" $ do
     it "gets first char" $
-      apply getc "hello" `shouldBe` [('h', "ello")]
+      _apply getc "hello" `shouldBe` Right ('h', "ello")
   describe "sat" $ do
     it "gets first char if happy" $
-      apply (sat isDigit) "1z" `shouldBe` [('1', "z")]
+      _apply (sat isDigit) "1z" `shouldBe` Right ('1', "z")
     it "gets a string until char" $
-      apply (many $ sat (/=';')) "hello : ;" `shouldBe` [("hello : ", ";")]
+      _apply (many $ sat (/=';')) "hello : ;" `shouldBe` Right ("hello : ", ";")
   -- describe "space" $ do
   --   it "eats line comments" $ do
   --     let s = many $ sat (/=';')
-  --     apply (many s) "hello // this is a comment\nbye" `shouldBe` [(["hello", "bye"], "")]
+  --     _apply (many s) "hello // this is a comment\nbye" `shouldBe` [(["hello", "bye"], "")]
   describe "char" $ do
     it "gets char" $ property $
-      \c-> apply (char c) (c:"dioscuri") === [(c, "dioscuri")]
+      \c-> _apply (char c) (c:"dioscuri") === Right (c, "dioscuri")
   describe "digit" $ do
     it "gets a digit" $
-      apply digit "2b" `shouldBe` [('2', "b")]
+      _apply digit "2b" `shouldBe` Right ('2', "b")
   describe "<|>" $ do
     it "returns empty if not matched" $
-      apply (digit <|> empty) "a2" `shouldBe` []
+      _apply (digit <|> empty) "a2" `shouldBe` Left Nothing
     it "returns a match if matched" $
-      apply (digit <|> empty) "2a" `shouldBe` [('2', "a")]
+      _apply (digit <|> empty) "2a" `shouldBe` Right ('2', "a")
 
   describe "some" $ do
     it "returns some digits" $
-      apply (some digit) "123x" `shouldBe` [("123", "x")]
+      _apply (some digit) "123x" `shouldBe` Right ("123", "x")
     it "alternates if some is not matched" $
-      apply (some digit <|> some lower) "b123" `shouldBe` [("b", "123")]
+      _apply (some digit <|> some lower) "b123" `shouldBe` Right ("b", "123")
 
   describe "many" $ do
     it "returns none if nothing is matched" $
-      apply (many digit) "abc" `shouldBe` [([], "abc")]
+      _apply (many digit) "abc" `shouldBe` Right ([], "abc")
   describe "optional'" $ do
     it "returns the item if matched" $
-      apply (optional' . some $ digit) "1a" `shouldBe` [("1", "a")]
+      _apply (optional' . some $ digit) "1a" `shouldBe` Right ("1", "a")
     it "returns the none if none matched" $
-      apply (optional' . some $ digit) "a1" `shouldBe` [("", "a1")]
+      _apply (optional' . some $ digit) "a1" `shouldBe` Right ("", "a1")
 
   describe "token" $ do
     it "parses a spaced number" $
-      apply (token $ some digit) "  123x" `shouldBe` [("123", "x")]
+      _apply (token $ some digit) "  123x" `shouldBe` Right ("123", "x")
   describe "symbol" $ do
     it "parses a spaced string" $
-      apply (symbol "hello") "   hello " `shouldBe` [((), " ")]
+      _apply (symbol "hello") "   hello " `shouldBe` Right ((), " ")
 
   describe "grouped" $ do
     it "parses a number surrounded by brackets" $
-      apply (grouped "[[" "]]" $ some digit) " [[123 ]] " `shouldBe` [("123", " ")]
+      _apply (grouped "[[" "]]" $ some digit) " [[123 ]] " `shouldBe` Right ("123", " ")
     it "parses a group within group of same brackets" $
-      apply (grouped "{" "}" $ do {
+      _apply (grouped "{" "}" $ do {
         symbol "+";
         grouped "{" "}" (some digit);
-      }) "{ +{123}}" `shouldBe` [("123", "")]
+      }) "{ +{123}}" `shouldBe` Right ("123", "")
     it "parses spaces and new lines" $
-      apply (grouped "{" "}" (token digit)) (unlines
+      _apply (grouped "{" "}" (token digit)) (unlines
       [ " { "
       , " 3 "
       , " } " 
-      ]) `shouldBe` [('3', " \n")]
+      ]) `shouldBe` Right ('3', " \n")
 
   describe "oneof" $ do
     it "parses one of" $ forAll (elements "hzu") $
-      \c -> apply (oneOf "hzu") (c:"hello") === [(c, "hello")]
+      \c -> _apply (oneOf "hzu") (c:"hello") === Right (c, "hello")
     it "parses none of" $ forAll (elements "hzu") $
-      \c -> apply (oneOf "abc") (c:"hello") === []
+      \c -> _apply (oneOf "abc") (c:"hello") === Left Nothing
 
   describe "enum" $ do
     it "parses" $
-      apply (enum ["aa", "bb"]) "aa" `shouldBe` [("aa", "")]
+      _apply (enum ["aa", "bb"]) "aa" `shouldBe` Right ("aa", "")
     it "parses manywith" $
-      apply (manywith (symbol ",") $ enum [ "aa", "bb" ]) "aa,bb , bb, aa" 
-        `shouldBe` [(["aa","bb","bb","aa"], "")]
+      _apply (manywith (symbol ",") $ enum [ "aa", "bb" ]) "aa,bb , bb, aa" 
+        `shouldBe` Right (["aa","bb","bb","aa"], "")
   describe "somewith" $ do
     it "parses into an array" $
-      apply (somewith (symbol ",") (token digit)) " 3, 4 , 5,6,3 ff+" `shouldBe` [("34563", " ff+")]
+      _apply (somewith (symbol ",") (token digit)) " 3, 4 , 5,6,3 ff+" `shouldBe` Right ("34563", " ff+")
+  describe "require" $ do
+    it "fails on missing requirements" $ do
+      let p = do symbol "start"
+                 num <- token  $ some digit
+                 require "expecting the end" $ symbol "end"
+                 return num
+
+      _apply p "start\n123" `shouldBe` failure ("expecting the end", 1, 3)
+
+    it "fails on a bad alternative" $ do
+      let q = symbol "{" >> require "digit required" (some digit)
+      let p = string "{" >> return "3"
+      _apply (q <|> p) "{" `shouldBe` failure ("digit required", 0, 1)
 
 
 

test/RuleGeneratorSpec.hs

@@ -26,7 +26,8 @@ repA = repN . repQ
 showN :: Show a => a -> String
 showN = repA . show
 showE (Right x) = "Right " ++ repA x
-showE (Left (Error loc x)) = "Left " ++ repA x
+showE (Left x) = "Left " ++ repA x
+-- showE (Left Nothing) = "Left Nothing"
 g = showE . RuleGenerator.generate
 gt z = (\x->trace (showN x) x) (g z)
 gu = g . trim . unlines