add few utility functions

Author: NicolasDP

Foundation/Parser.hs

@@ -18,6 +18,7 @@
 
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Foundation.Parser
     ( Parser(..)
@@ -37,6 +38,10 @@ module Foundation.Parser
     , skip
     , skipWhile
     , skipAll
+    -- utils
+    , optional
+    , many, many'
+    , atLeast, atLeast'
     ) where
 
 import           Control.Applicative (Alternative, empty, (<|>))
@@ -254,3 +259,38 @@ skipWhile p = Parser $ \buf err ok ->
 -- stream
 skipAll :: Sequential input => Parser input ()
 skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok
+
+-- | make parsing an element optional
+--
+-- > newtype HELP = HELP (Maybe String) -- the SMTP help command
+-- > parserHELP :: Parser (UArray Word8) HELP
+-- > parserHELP = do
+-- >    elements "HELP"
+-- >    mstr <- (HELP <$> optional (takeWhileNotCRLF))
+-- >    elements "\r\n"
+-- >    return $ HELP mstr
+--
+optional :: Parser input a -> Parser input (Maybe a)
+optional p = (Just <$> p) <|> pure Nothing
+
+-- | apply the parser 0 or more times
+--
+-- > many anyElement === takeAll
+many :: (Sequential c, Item c ~ a) => Parser input a -> Parser input c
+many !p = (p >>= \v -> mappend (singleton v) <$> many p) <|> pure mempty
+
+-- | same as `many` but specialised for list
+many' :: Parser input a -> Parser input [a]
+many' = many
+
+-- | apply the parser at least a certain amount of time
+--
+-- > (head <$> atLeast 1 p) === anyElement
+--
+atLeast :: (Sequential c, Item c ~ a) => Int -> Parser input a -> Parser input c
+atLeast  0 !p = many p
+atLeast !n !p = p >>= \x -> mappend (singleton x) <$> atLeast (n - 1) p
+
+-- | same as `atLeast` but specialised for list
+atLeast' :: Int -> Parser input a -> Parser input [a]
+atLeast' = atLeast

tests/Parser.hs

@@ -6,7 +6,6 @@ module Parser
   ) where
 
 import Foundation
-import Foundation.String
 import Foundation.Parser
 
 import Test.Tasty
@@ -23,7 +22,7 @@ parseTestCase :: (Show a, Eq a)
               -> Parser String a
               -> TestCaseRes a
               -> Assertion
-parseTestCase buff parser res = check (parse parser buff) res
+parseTestCase buff parser = check (parse parser buff)
 check :: (Show a, Eq a) => Result String a -> TestCaseRes a -> Assertion
 check r e = case (r, e) of
     (ParseOK remain a, TestCaseOk eRemain ea) -> do
@@ -71,7 +70,7 @@ parseTestCases = testGroup "units"
         , testCase "MoreFail" $ parseTestCase "aa" (takeWhile (' ' /=)) $ TestCaseMore Nothing TestCaseFail
         ]
     , testGroup "takeAll"
-        [ testCase "OK" $ parseTestCase "abc" (takeAll) (TestCaseMore Nothing $ TestCaseOk "" "abc")
+        [ testCase "OK" $ parseTestCase "abc" takeAll (TestCaseMore Nothing $ TestCaseOk "" "abc")
         ]
     , testGroup "skip"
         [ testCase "OK" $ parseTestCase "a" (skip 1) (TestCaseOk "" ())
@@ -86,7 +85,16 @@ parseTestCases = testGroup "units"
         , testCase "MoreFail" $ parseTestCase "aa" (skipWhile (' ' /=)) $ TestCaseMore Nothing TestCaseFail
         ]
     , testGroup "skipAll"
-        [ testCase "OK" $ parseTestCase "abc" (skipAll) (TestCaseMore Nothing $ TestCaseOk "abc" ())
+        [ testCase "OK" $ parseTestCase "abc" skipAll (TestCaseMore Nothing $ TestCaseOk "abc" ())
+        ]
+    , testGroup "optional"
+        [ testCase "Nothing" $ parseTestCase "aaa" (optional $ elements "bbb") (TestCaseOk "aaa" Nothing)
+        , testCase "Just"    $ parseTestCase "aaa" (optional $ elements "a") (TestCaseOk "aa" (Just ()))
+        ]
+    , testGroup "many"
+        [ testCase "many elements" $ parseTestCase "101010\0"
+            (many ((element '1' >> pure True) <|> (element '0' >> pure False) ) )
+            (TestCaseOk "\0" [True, False, True, False, True, False])
         ]
     ]