boomerang 1.3.0 → 1.3.1

raw patch · 10 files changed

+120/−77 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Text/Boomerang.hs +3/−3
• Text/Boomerang/Combinators.hs +10/−10
• Text/Boomerang/Error.hs +6/−6
• Text/Boomerang/HStack.hs +1/−1
• Text/Boomerang/Pos.hs +5/−5
• Text/Boomerang/Prim.hs +21/−20
• Text/Boomerang/String.hs +16/−10
• Text/Boomerang/Strings.hs +55/−19
• Text/Boomerang/TH.hs +2/−2
• boomerang.cabal +1/−1

@@ -51,8 +51,8 @@ Now we can define a grammar:  > foo :: StringPrinterParser () (Foo :- ())-> foo = ->     (  rBar +> foo =+>     (  rBar >     <> rBaz . "baz-" . int . "-" . alpha >     ) @@ -108,7 +108,7 @@ >                Nothing  -> putStrLn "unparseString failed to produce a value." >                (Just s) -> putStrLn $ "Pretty: " ++ s -> main = forever $ +> main = forever $ >     do putStr "Enter a string to parse: " >        hFlush stdout >        l <- getLine

@@ -1,6 +1,6 @@ -- | a collection of generic parsing combinators that can work with any token and error type. {-# LANGUAGE TemplateHaskell, TypeOperators #-}-module Text.Boomerang.Combinators +module Text.Boomerang.Combinators     ( (<>), duck, duck1, opt     , manyr, somer, chainr, chainr1, manyl, somel, chainl, chainl1     , rFilter, printAs, push, rNil, rCons, rList, rList1, rListSep, rPair@@ -49,12 +49,12 @@ somer :: PrinterParser e tok r r -> PrinterParser e tok r r somer p = p . manyr p --- | @chainr p op@ repeats @p@ zero or more times, separated by @op@. +-- | @chainr p op@ repeats @p@ zero or more times, separated by @op@. --   The result is a right associative fold of the results of @p@ with the results of @op@. chainr :: PrinterParser e tok r r -> PrinterParser e tok r r -> PrinterParser e tok r r chainr p op = opt (manyr (p .~ op) . p) --- | @chainr1 p op@ repeats @p@ one or more times, separated by @op@. +-- | @chainr1 p op@ repeats @p@ one or more times, separated by @op@. --   The result is a right associative fold of the results of @p@ with the results of @op@. chainr1 :: PrinterParser e tok r (a :- r) -> PrinterParser e tok (a :- a :- r) (a :- r) -> PrinterParser e tok r (a :- r) chainr1 p op = manyr (duck p .~ op) . p@@ -67,30 +67,30 @@ somel :: PrinterParser e tok r r -> PrinterParser e tok r r somel p = p .~ manyl p --- | @chainl1 p op@ repeats @p@ zero or more times, separated by @op@. +-- | @chainl1 p op@ repeats @p@ zero or more times, separated by @op@. --   The result is a left associative fold of the results of @p@ with the results of @op@. chainl :: PrinterParser e tok r r -> PrinterParser e tok r r -> PrinterParser e tok r r chainl p op = opt (p .~ manyl (op . p)) --- | @chainl1 p op@ repeats @p@ one or more times, separated by @op@. +-- | @chainl1 p op@ repeats @p@ one or more times, separated by @op@. --   The result is a left associative fold of the results of @p@ with the results of @op@. chainl1 :: PrinterParser e tok r (a :- r) -> PrinterParser e tok (a :- a :- r) (a :- r) -> PrinterParser e tok r (a :- r) chainl1 p op = p .~ manyl (op . duck p)  -- | Filtering on routers.--- +-- -- TODO: We remove any parse errors, not sure if the should be preserved. Also, if the predicate fails we silently remove the element, but perhaps we should replace the value with an error message?-rFilter :: (a -> Bool) -> PrinterParser e tok () (a :- ()) -> PrinterParser e tok r (a :- r) +rFilter :: (a -> Bool) -> PrinterParser e tok () (a :- ()) -> PrinterParser e tok r (a :- r) rFilter p r = val ps ss     where-      ps = Parser $ \tok pos -> +      ps = Parser $ \tok pos ->            let parses = runParser (prs r) tok pos            in [ Right ((a, tok), pos) | (Right ((f, tok), pos)) <- parses, let a = hhead (f ()), p a]       ss = \a -> [ f | p a, (f, _) <- ser r (a :- ()) ]  -- | @r \`printAs\` s@ uses ther serializer of @r@ to test if serializing succeeds,---   and if it does, instead serializes as @s@. --- +--   and if it does, instead serializes as @s@.+-- -- TODO: can this be more general so that it can work on @tok@ instead of @[tok]@ printAs :: PrinterParser e [tok] a b -> tok -> PrinterParser e [tok] a b printAs r s = r { ser = map (first (const (s :))) . take 1 . ser r }

@@ -43,7 +43,7 @@     strMsg s = ParserError Nothing [Message s]  -- | lift a 'pos' and '[ErrorMsg]' into a parse error--- +-- -- This is intended to be used inside a 'Parser' like this: -- -- > Parser $ \tok pos -> mkParserError pos [Message "just some error..."]@@ -56,13 +56,13 @@ -- -- > satisfy isUpper <?> 'an uppercase character' (<?>) :: PrinterParser (ParserError p) tok a b -> String -> PrinterParser (ParserError p) tok a b-router <?> msg = +router <?> msg =     router { prs = Parser $ \tok pos ->         map (either (\(ParserError mPos errs) -> Left $ ParserError mPos ((Expect msg) : errs)) Right) (runParser (prs router) tok pos) }  -- | condense the 'ParserError's with the highest parse position into a single 'ParserError' condenseErrors :: (Ord pos) => [ParserError pos] -> ParserError pos-condenseErrors errs = +condenseErrors errs =     case bestErrors errs of       [] -> ParserError Nothing []       errs'@(ParserError pos _ : _) ->@@ -92,11 +92,11 @@        showExpect      = showMany msgExpecting expect       showUnExpect    = showMany msgUnExpected unExpect-      showSysUnExpect +      showSysUnExpect           | null sysUnExpect = ""-          | otherwise        = +          | otherwise        =               let msg = head sysUnExpect-              in msgUnExpected ++ " " ++ +              in msgUnExpected ++ " " ++                      if (isEOI msg) then msgEndOfInput ++ " " ++ (messageString $ head sysUnExpect)                                     else messageString $ head sysUnExpect       showMessages      = showMany "" msgs3

@@ -2,7 +2,7 @@ {-# LANGUAGE TypeOperators #-} module Text.Boomerang.HStack     ( (:-)(..)-    , arg, hdTraverse, hdMap, hhead, htail, pop +    , arg, hdTraverse, hdMap, hhead, htail, pop     ) where  infixr 8 :-

@@ -5,7 +5,7 @@     , ErrorPosition(..)     , MajorMinorPos(..)     , incMajor, incMinor-    ) +    )     where  import Data.Data (Data, Typeable)@@ -13,7 +13,7 @@ -- | type synonym family that maps an error type to its position type type family Pos err :: * --- | extract the position information from an error +-- | extract the position information from an error class ErrorPosition err where     getPosition :: err -> Maybe (Pos err) @@ -22,13 +22,13 @@     initialPos :: Maybe e -> Pos e  -- | A basic 2-axis position type (e.g. line, character)-data MajorMinorPos = MajorMinorPos -    { major :: Integer +data MajorMinorPos = MajorMinorPos+    { major :: Integer     , minor :: Integer     }     deriving (Eq, Ord, Typeable, Data) --- | increment major position by 'i', reset minor position to 0.. +-- | increment major position by 'i', reset minor position to 0.. -- if you wanted something else.. too bad. incMajor :: (Integral i) => i -> MajorMinorPos -> MajorMinorPos incMajor i (MajorMinorPos maj min) = MajorMinorPos (maj + (fromIntegral i)) 0

@@ -36,25 +36,26 @@ -- The list must be finite and non-empty. maximumsBy               :: (a -> a -> Ordering) -> [a] -> [a] maximumsBy _ []          =  error "Text.Boomerang.Core.maximumsBy: empty list"-maximumsBy cmp (x:xs)        =  foldl maxBy [x] xs-                        where-                           maxBy xs@(x:_) y = case cmp x y of-                                       GT -> xs-                                       EQ -> (y:xs)-                                       LT  -> [y]+maximumsBy cmp (x:xs)    =  foldl maxBy [x] xs+    where+      maxBy xs@(x:_) y =+          case cmp x y of+            GT -> xs+            EQ -> (y:xs)+            LT  -> [y] --- |Yet another parser. +-- |Yet another parser. -- -- Returns all possible parses and parse errors newtype Parser e tok a = Parser { runParser :: tok -> Pos e -> [Either e ((a, tok), Pos e)] }  instance Functor (Parser e tok) where-    fmap f (Parser p) = +    fmap f (Parser p) =         Parser $ \tok pos ->             map (fmap (first (first f))) (p tok pos)  instance Monad (Parser e tok) where-    return a = +    return a =         Parser $ \tok pos ->             [Right ((a, tok), pos)]     (Parser p) >>= f =@@ -75,13 +76,13 @@   -> Parser e tok a   -> Parser e tok b   -> Parser e tok c-composeP op mf mg = +composeP op mf mg =     do f <- mf        g <- mg        return (f `op` g)  -- | Attempt to extract the most relevant errors from a list of parse errors.--- +-- -- The current heuristic is to find error (or errors) where the error position is highest. bestErrors :: (ErrorPosition e, Ord (Pos e)) => [e] -> [e] bestErrors [] = []@@ -99,23 +100,23 @@     (return id)     (\x -> [(id, x)]) -  ~(PrinterParser pf sf) . ~(PrinterParser pg sg) = PrinterParser +  ~(PrinterParser pf sf) . ~(PrinterParser pg sg) = PrinterParser     (composeP (.) pf pg)-    (compose (.) sf sg) +    (compose (.) sf sg)  instance Monoid (PrinterParser e tok a b) where-  mempty = PrinterParser +  mempty = PrinterParser     mzero     (const mzero) -  ~(PrinterParser pf sf) `mappend` ~(PrinterParser pg sg) = PrinterParser +  ~(PrinterParser pf sf) `mappend` ~(PrinterParser pg sg) = PrinterParser     (pf `mplus` pg)     (\s -> sf s `mplus` sg s)  infixr 9 .~ -- | Reverse composition, but with the side effects still in left-to-right order. (.~) :: PrinterParser e tok a b -> PrinterParser e tok b c -> PrinterParser e tok a c-~(PrinterParser pf sf) .~ ~(PrinterParser pg sg) = PrinterParser +~(PrinterParser pf sf) .~ ~(PrinterParser pg sg) = PrinterParser   (composeP (flip (.)) pf pg)   (compose (flip (.)) sg sf) @@ -144,14 +145,14 @@  -- | Give all possible parses or errors. parse :: forall e a p tok. (InitialPosition e) => PrinterParser e tok () a -> tok -> [Either e (a, tok)]-parse p s = +parse p s =     map (either Left (\((f, tok), _) -> Right (f (), tok))) $ runParser (prs p) s (initialPos (Nothing :: Maybe e)) --- | Give the first parse, for PrinterParsers with a parser that yields just one value. +-- | Give the first parse, for PrinterParsers with a parser that yields just one value. -- Otherwise return the error (or errors) with the highest error position. parse1 :: (ErrorPosition e, InitialPosition e, Show e, Ord (Pos e)) =>           (tok -> Bool) -> PrinterParser e tok () (a :- ()) -> tok -> Either [e] a-parse1 isComplete r paths = +parse1 isComplete r paths =     let results = parse r paths     in case [ a | (Right (a,tok)) <- results, isComplete tok ] of          ((u :- ()):_) -> Right u@@ -163,7 +164,7 @@  -- | Give the first serialization, for PrinterParsers with a serializer that needs just one value. unparse1 :: tok -> PrinterParser e tok () (a :- ()) -> a -> Maybe tok-unparse1 tok p a = +unparse1 tok p a =     case unparse tok p (a :- ()) of       [] -> Nothing       (s:_) -> Just s

@@ -9,7 +9,7 @@     , integer, lit, satisfy, space     -- * Running the 'PrinterParser'     , isComplete, parseString, unparseString-    ) +    )     where  import Prelude                 hiding ((.), id, (/))@@ -30,10 +30,9 @@ instance InitialPosition StringError where     initialPos _ = MajorMinorPos 0 0 - -- | a constant string lit :: String -> StringPrinterParser r r-lit l = PrinterParser pf sf +lit l = PrinterParser pf sf     where       pf = Parser $ \tok pos ->            case tok of@@ -54,13 +53,13 @@ -- | statisfy a 'Char' predicate satisfy :: (Char -> Bool) -> StringPrinterParser r (Char :- r) satisfy p = val-  (Parser $ \tok pos -> +  (Parser $ \tok pos ->        case tok of          []          -> mkParserError pos [EOI "input"]          (c:cs)-             | p c -> +             | p c ->                  do [Right ((c, cs), if (c == '\n') then incMajor 1 pos else incMinor 1 pos)]-             | otherwise -> +             | otherwise ->                  do mkParserError pos [SysUnExpect $ show c]   )   (\c -> [ \paths -> (c:paths) | p c ])@@ -69,7 +68,7 @@ digit :: StringPrinterParser r (Char :- r) digit = satisfy isDigit <?> "a digit 0-9" --- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, +-- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, -- plus letters of caseless scripts and modifiers letters).  (Uses 'isAlpha') alpha :: StringPrinterParser r (Char :- r) alpha = satisfy isAlpha <?> "an alphabetic Unicode character"@@ -86,13 +85,20 @@ char :: Char -> StringPrinterParser r (Char :- r) char c = satisfy (== c) <?> show [c] +readIntegral :: (Read a, Eq a, Num a) => String -> a+readIntegral s =+    case reads s of+      [(x, [])] -> x+      []  -> error "readIntegral: no parse"+      _   -> error "readIntegral: ambiguous parse"+ -- | matches an 'Int' int :: StringPrinterParser r (Int :- r)-int = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))+int = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))  -- | matches an 'Integer' integer :: StringPrinterParser r (Integer :- r)-integer = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))+integer = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))  -- | Predicate to test if we have parsed all the strings. -- Typically used as argument to 'parse1'@@ -109,7 +115,7 @@ parseString :: StringPrinterParser () (r :- ())              -> String              -> Either StringError r-parseString pp strs = +parseString pp strs =     either (Left . condenseErrors) Right $ parse1 isComplete pp strs  -- | run the printer

@@ -6,10 +6,10 @@       StringsError     -- * Combinators     , (</>), alpha, anyChar, anyString, char, digit, eos, int-    , integer, lit, satisfy, satisfyStr, space+    , integer, lit, readshow, satisfy, satisfyStr, space     -- * Running the 'PrinterParser'     , isComplete, parseStrings, unparseStrings-    +     )     where @@ -35,7 +35,7 @@  -- | a constant string lit :: String -> PrinterParser StringsError [String] r r-lit l = PrinterParser pf sf +lit l = PrinterParser pf sf     where       pf = Parser $ \tok pos ->            case tok of@@ -43,9 +43,9 @@              ("":_) | (not $ null l) -> mkParserError pos [EOI "segment", Expect (show l)]              (p:ps) ->                  case stripPrefix l p of-                   (Just p') -> +                   (Just p') ->                        do [Right ((id, p':ps), incMinor (length l) pos)]-                   Nothing -> +                   Nothing ->                        mkParserError pos [UnExpect (show p), Expect (show l)]       sf b = [ (\strings -> case strings of [] -> [l] ; (s:ss) -> ((l ++ s) : ss), b)] @@ -56,11 +56,11 @@  -- | end of string eos :: PrinterParser StringsError [String] r r-eos = PrinterParser +eos = PrinterParser        (Parser $ \path pos -> case path of                    []      -> [Right ((id, []), incMajor 1 pos)] --                   [] -> mkParserError pos [EOI "input"]-                   ("":ps) -> +                   ("":ps) ->                           [ Right ((id, ps), incMajor 1 pos) ]                    (p:_) -> mkParserError pos [Message $ "path-segment not entirely consumed: " ++ p])        (\a -> [(("" :), a)])@@ -68,32 +68,32 @@ -- | statisfy a 'Char' predicate satisfy :: (Char -> Bool) -> PrinterParser StringsError [String] r (Char :- r) satisfy p = val-  (Parser $ \tok pos -> +  (Parser $ \tok pos ->        case tok of          []          -> mkParserError pos [EOI "input"]          ("":ss)     -> mkParserError pos [EOI "segment"]          ((c:cs):ss)-             | p c -> +             | p c ->                  do [Right ((c, cs : ss), incMinor 1 pos )]-             | otherwise -> +             | otherwise ->                  do mkParserError pos [SysUnExpect $ show c]   )   (\c -> [ \paths -> case paths of [] -> [[c]] ; (s:ss) -> ((c:s):ss) | p c ])  --- | satisfy a 'String' predicate. +-- | satisfy a 'String' predicate. -- -- Note: must match the entire remainder of the 'String' in this segment satisfyStr :: (String -> Bool) -> PrinterParser StringsError [String] r (String :- r) satisfyStr p = val-  (Parser $ \tok pos -> +  (Parser $ \tok pos ->        case tok of          []          -> mkParserError pos [EOI "input"]          ("":ss)     -> mkParserError pos [EOI "segment"]          (s:ss)-             | p s -> +             | p s ->                  do [Right ((s, "":ss), incMajor 1 pos )]-             | otherwise -> +             | otherwise ->                  do mkParserError pos [SysUnExpect $ show s]   )   (\str -> [ \strings -> case strings of [] -> [str] ; (s:ss) -> ((str++s):ss) | p str ])@@ -103,7 +103,7 @@ digit :: PrinterParser StringsError [String] r (Char :- r) digit = satisfy isDigit <?> "a digit 0-9" --- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, +-- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, -- plus letters of caseless scripts and modifiers letters).  (Uses 'isAlpha') alpha :: PrinterParser StringsError [String] r (Char :- r) alpha = satisfy isAlpha <?> "an alphabetic Unicode character"@@ -120,17 +120,53 @@ char :: Char -> PrinterParser StringsError [String] r (Char :- r) char c = satisfy (== c) <?> show [c] +-- | lift 'Read'/'Show' to a 'PrinterParser'+--+-- There are a few restrictions here:+--+--  1. Error messages are a bit fuzzy. `Read` does not tell us where+--  or why a parse failed. So all we can do it use the the position+--  that we were at when we called read and say that it failed.+--+--  2. it is (currently) not safe to use 'readshow' on integral values+--  because the 'Read' instance for 'Int', 'Integer', etc,+readshow :: (Read a, Show a) => PrinterParser StringsError [String] r (a :- r)+readshow =+    val readParser s+    where+      s a = [ \strings -> case strings of [] -> [show a] ; (s:ss) -> (((show a)++s):ss) ]++readParser :: (Read a) => Parser StringsError [String] a+readParser =+    Parser $ \tok pos ->+        case tok of+          []     -> mkParserError pos [EOI "input"]+          ("":_) -> mkParserError pos [EOI "segment"]+          (p:ps) ->+            case reads p of+              [] -> mkParserError pos [SysUnExpect p, Message $ "decoding using 'read' failed."]+              [(a,r)] ->+                  [Right ((a, r:ps), incMinor ((length p) - (length r)) pos)]++readIntegral :: (Read a, Eq a, Num a) => String -> a+readIntegral s =+    case reads s of+      [(x, [])] -> x+      []  -> error "readIntegral: no parse"+      _   -> error "readIntegral: ambiguous parse"++ -- | matches an 'Int' -- -- Note that the combinator @(rPair . int . int)@ is ill-defined because the parse can not tell where it is supposed to split the sequence of digits to produced two ints. int :: PrinterParser StringsError [String] r (Int :- r)-int = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))+int = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))  -- | matches an 'Integer' -- -- Note that the combinator @(rPair . integer . integer)@ is ill-defined because the parse can not tell where it is supposed to split the sequence of digits to produced two ints. integer :: PrinterParser StringsError [String] r (Integer :- r)-integer = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))+integer = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit))  -- | matches any 'String' --@@ -150,7 +186,7 @@ -- -- We will get @Right ("foobar","")@ instead of the original @Right ("foo","bar")@ anyString :: PrinterParser StringsError [String] r (String :- r)-anyString = val ps ss +anyString = val ps ss     where       ps = Parser $ \tok pos ->            case tok of@@ -179,7 +215,7 @@ parseStrings :: PrinterParser StringsError [String] () (r :- ())              -> [String]              -> Either StringsError r-parseStrings pp strs = +parseStrings pp strs =     either (Left . condenseErrors) Right $ parse1 isComplete pp strs  -- | run the printer

@@ -2,11 +2,11 @@ module Text.Boomerang.TH (derivePrinterParsers) where  import Control.Monad       (liftM, replicateM)-import Language.Haskell.TH +import Language.Haskell.TH import Text.Boomerang.HStack   ((:-)(..), arg) import Text.Boomerang.Prim    (xpure, PrinterParser) --- | Derive routers for all constructors in a datatype. For example: +-- | Derive routers for all constructors in a datatype. For example: -- --   @$(derivePrinterParsers \'\'Sitemap)@ derivePrinterParsers :: Name -> Q [Dec]

@@ -1,5 +1,5 @@ Name:             boomerang-Version:          1.3.0+Version:          1.3.1 License:          BSD3 License-File:     LICENSE Author:           jeremy@seereason.com