boomerang-1.4.5.2/0000755000000000000000000000000012724634110012020 5ustar0000000000000000boomerang-1.4.5.2/boomerang.cabal0000644000000000000000000000350512724634110014760 0ustar0000000000000000Name: boomerang Version: 1.4.5.2 License: BSD3 License-File: LICENSE Author: jeremy@seereason.com Maintainer: partners@seereason.com Bug-Reports: http://code.google.com/p/happstack/issues/list Category: Parsing, Text Synopsis: Library for invertible parsing and printing Description: Specify a single unified grammar which can be used for parsing and pretty-printing Cabal-Version: >= 1.6 Build-type: Simple tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Library Build-Depends: base >= 4 && < 5, mtl >= 2.0 && < 2.3, template-haskell < 2.12, text >= 0.11 && < 1.3 Exposed-Modules: Text.Boomerang Text.Boomerang.Combinators Text.Boomerang.Error Text.Boomerang.HStack Text.Boomerang.Pos Text.Boomerang.Prim Text.Boomerang.String Text.Boomerang.Strings Text.Boomerang.Texts Text.Boomerang.TH Extensions: DeriveDataTypeable, FlexibleContexts, FlexibleContexts, FlexibleInstances, RankNTypes, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeFamilies, TypeOperators, TypeSynonymInstances source-repository head type: git location: https://github.com/Happstack/boomerang.git boomerang-1.4.5.2/LICENSE0000644000000000000000000000305712724634110013032 0ustar0000000000000000Copyright (c) 2010, Sjoerd Visscher & Martijn van Steenbergen Copyright (c) 2011, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jeremy Shaw nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. boomerang-1.4.5.2/Setup.hs0000644000000000000000000000005612724634110013455 0ustar0000000000000000import Distribution.Simple main = defaultMain boomerang-1.4.5.2/Text/0000755000000000000000000000000012724634110012744 5ustar0000000000000000boomerang-1.4.5.2/Text/Boomerang.hs0000644000000000000000000000624412724634110015217 0ustar0000000000000000{-| Module : Text.Boomerang Boomerang is a DSL for creating parsers and pretty-printers using a single specification. Instead of writing a parser, and then writing a separate pretty-printer, both are created at once. This saves time, and ensures that the parser and pretty-printer are inverses and stay in-sync with each other. Boomerang is a generalized derivative of the Zwaluw library created by Sjoerd Visscher and Martijn van Steenbergen: Boomerang is similar in purpose, but different in implementation to: Here is a simple example. First we enable three language extensions: @ {\-\# LANGUAGE TemplateHaskell, TypeOperators, OverloadedStrings \#-\} @ In the imports, note that we hide @((.), id)@ from 'Prelude' and use @((.), id)@ from "Control.Category" instead. > {-# LANGUAGE TemplateHaskell, TypeOperators, OverloadedStrings #-} > module Main where > > import Prelude hiding ((.), id) > import Control.Category ((.), id) > import Control.Monad (forever) > import Text.Boomerang > import Text.Boomerang.String > import Text.Boomerang.TH > import System.IO (hFlush, stdout) Next we define a type that we want to be able to pretty-print and define parsers for: > data Foo > = Bar > | Baz Int Char > deriving (Eq, Show) Then we generate some combinators for the type: > $(makeBoomerangs ''Foo) The combinators will be named after the constructors, but with an r prefixed to them. In this case, @rBar@ and @rBaz@. Now we can define a grammar: > foo :: StringBoomerang () (Foo :- ()) > foo = > ( rBar > <> rBaz . "baz-" . int . "-" . alpha > ) @.@ is used to compose parsers together. '<>' is used for choice. Now we can use @foo@ as a printer or a parser. Here is an example of a successful parse: > test1 = parseString foo "baz-2-c" @ *Main> test1 Right (Baz 2 'c') @ And another example: > test2 = parseString foo "" @ *Main> test2 Right Bar @ Here is an example of a parse error: > test3 = parseString foo "baz-2-3" @ *Main> test3 Left parse error at (0, 6): unexpected '3'; expecting an alphabetic Unicode character @ we can also use @foo@ to pretty-print a value: > test4 = unparseString foo (Baz 1 'z') @ *Main> test4 Just "baz-1-z" @ Here is a little app that allows you to interactively test @foo@. > testInvert :: String -> IO () > testInvert str = > case parseString foo str of > (Left e) -> print e > (Right f') -> > do putStrLn $ "Parsed: " ++ show f' > case unparseString foo f' of > Nothing -> putStrLn "unparseString failed to produce a value." > (Just s) -> putStrLn $ "Pretty: " ++ s > main = forever $ > do putStr "Enter a string to parse: " > hFlush stdout > l <- getLine > testInvert l -} module Text.Boomerang ( module Text.Boomerang.Combinators , module Text.Boomerang.Error , module Text.Boomerang.HStack , module Text.Boomerang.Prim , module Text.Boomerang.Pos ) where import Text.Boomerang.Combinators import Text.Boomerang.Error import Text.Boomerang.HStack import Text.Boomerang.Prim import Text.Boomerang.Pos boomerang-1.4.5.2/Text/Boomerang/0000755000000000000000000000000012724634110014655 5ustar0000000000000000boomerang-1.4.5.2/Text/Boomerang/Combinators.hs0000644000000000000000000001445212724634110017477 0ustar0000000000000000-- | a collection of generic parsing combinators that can work with any token and error type. {-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-} module Text.Boomerang.Combinators ( (<>), duck, duck1, opt , manyr, somer, chainr, chainr1, manyl, somel, chainl, chainl1 , rFilter, printAs, push, rNil, rCons, rList, rList1, rListSep, rPair , rLeft, rRight, rEither, rNothing, rJust, rMaybe , rTrue, rFalse, rBool, rUnit ) where import Control.Arrow (first, second) import Prelude hiding ((.), id, (/)) import Control.Category (Category((.), id)) import Control.Monad (guard) import Control.Monad.Error (Error) import Text.Boomerang.Prim (Parser(..), Boomerang(..), (.~), val, xpure) import Text.Boomerang.HStack ((:-)(..), arg, hhead) import Text.Boomerang.TH (makeBoomerangs) #if MIN_VERSION_base(4,5,0) import Data.Monoid (Monoid(mappend), (<>)) #else import Data.Monoid (Monoid(mappend)) infixr 6 <> -- | Infix operator for 'mappend'. (<>) :: Monoid m => m -> m -> m (<>) = mappend #endif -- | Convert a router to do what it does on the tail of the stack. duck :: Boomerang e tok r1 r2 -> Boomerang e tok (h :- r1) (h :- r2) duck r = Boomerang (fmap (\f (h :- t) -> h :- f t) $ prs r) (\(h :- t) -> map (second (h :-)) $ ser r t) -- | Convert a router to do what it does on the tail of the stack. duck1 :: Boomerang e tok r1 (a :- r2) -> Boomerang e tok (h :- r1) (a :- h :- r2) duck1 r = Boomerang (fmap (\f (h :- t) -> let a :- t' = f t in a :- h :- t') $ prs r) (\(a :- h :- t) -> map (second (h :-)) $ ser r (a :- t)) -- | Make a router optional. opt :: Boomerang e tok r r -> Boomerang e tok r r opt = (id <>) -- | Repeat a router zero or more times, combining the results from left to right. manyr :: Boomerang e tok r r -> Boomerang e tok r r manyr = opt . somer -- | Repeat a router one or more times, combining the results from left to right. somer :: Boomerang e tok r r -> Boomerang e tok r r somer p = p . manyr p -- | @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 :: Boomerang e tok r r -> Boomerang e tok r r -> Boomerang e tok r r chainr p op = opt (manyr (p .~ op) . p) -- | @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 :: Boomerang e tok r (a :- r) -> Boomerang e tok (a :- a :- r) (a :- r) -> Boomerang e tok r (a :- r) chainr1 p op = manyr (duck p .~ op) . p -- | Repeat a router zero or more times, combining the results from right to left. manyl :: Boomerang e tok r r -> Boomerang e tok r r manyl = opt . somel -- | Repeat a router one or more times, combining the results from right to left. somel :: Boomerang e tok r r -> Boomerang e tok r r somel p = p .~ manyl p -- | @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 :: Boomerang e tok r r -> Boomerang e tok r r -> Boomerang e tok r r chainl p op = opt (p .~ manyl (op . p)) -- | @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 :: Boomerang e tok r (a :- r) -> Boomerang e tok (a :- a :- r) (a :- r) -> Boomerang 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) -> Boomerang e tok () (a :- ()) -> Boomerang e tok r (a :- r) rFilter p r = val ps ss where 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@. -- -- TODO: can this be more general so that it can work on @tok@ instead of @[tok]@ printAs :: Boomerang e [tok] a b -> tok -> Boomerang e [tok] a b printAs r s = r { ser = map (first (const (s :))) . take 1 . ser r } -- | Push a value on the stack (during parsing, pop it from the stack when serializing). push :: (Eq a, Error e) => a -> Boomerang e tok r (a :- r) push a = xpure (a :-) (\(a' :- t) -> guard (a' == a) >> Just t) rNil :: Boomerang e tok r ([a] :- r) rNil = xpure ([] :-) $ \(xs :- t) -> do [] <- Just xs; Just t rCons :: Boomerang e tok (a :- [a] :- r) ([a] :- r) rCons = xpure (arg (arg (:-)) (:)) $ \(xs :- t) -> do a:as <- Just xs; Just (a :- as :- t) -- | Converts a router for a value @a@ to a router for a list of @a@. rList :: Boomerang e tok r (a :- r) -> Boomerang e tok r ([a] :- r) rList r = manyr (rCons . duck1 r) . rNil -- | Converts a router for a value @a@ to a router for a list of @a@. rList1 :: Boomerang e tok r (a :- r) -> Boomerang e tok r ([a] :- r) rList1 r = somer (rCons . duck1 r) . rNil -- | Converts a router for a value @a@ to a router for a list of @a@, with a separator. rListSep :: Boomerang e tok r (a :- r) -> Boomerang e tok ([a] :- r) ([a] :- r) -> Boomerang e tok r ([a] :- r) rListSep r sep = chainr (rCons . duck1 r) sep . rNil rPair :: Boomerang e tok (f :- s :- r) ((f, s) :- r) rPair = xpure (arg (arg (:-)) (,)) $ \(ab :- t) -> do (a,b) <- Just ab; Just (a :- b :- t) $(makeBoomerangs ''Either) -- | Combines a router for a value @a@ and a router for a value @b@ into a router for @Either a b@. rEither :: Boomerang e tok r (a :- r) -> Boomerang e tok r (b :- r) -> Boomerang e tok r (Either a b :- r) rEither l r = rLeft . l <> rRight . r $(makeBoomerangs ''Maybe) -- | Converts a router for a value @a@ to a router for a @Maybe a@. rMaybe :: Boomerang e tok r (a :- r) -> Boomerang e tok r (Maybe a :- r) rMaybe r = rJust . r <> rNothing $(makeBoomerangs ''Bool) rBool :: Boomerang e tok a r -- ^ 'True' parser -> Boomerang e tok a r -- ^ 'False' parser -> Boomerang e tok a (Bool :- r) rBool t f = rTrue . t <> rFalse . f rUnit :: Boomerang e tok r (() :- r) rUnit = xpure ((:-) ()) (\ (() :- x) -> Just x) boomerang-1.4.5.2/Text/Boomerang/Error.hs0000644000000000000000000001170312724634110016304 0ustar0000000000000000-- | An Error handling scheme that can be used with 'Boomerang' {-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Text.Boomerang.Error where import Control.Monad.Error (Error(..)) import Data.Data (Data, Typeable) import Data.List (intercalate, sort, nub) import Text.Boomerang.Prim import Text.Boomerang.Pos data ErrorMsg = SysUnExpect String | EOI String | UnExpect String | Expect String | Message String deriving (Eq, Ord, Read, Show, Typeable, Data) -- | extract the 'String' from an 'ErrorMsg'. -- Note: the resulting 'String' will not include any information about what constructor it came from. messageString :: ErrorMsg -> String messageString (Expect s) = s messageString (UnExpect s) = s messageString (SysUnExpect s) = s messageString (EOI s) = s messageString (Message s) = s data ParserError pos = ParserError (Maybe pos) [ErrorMsg] deriving (Eq, Ord, Typeable, Data) type instance Pos (ParserError p) = p instance ErrorPosition (ParserError p) where getPosition (ParserError mPos _) = mPos {- instance ErrorList ParserError where listMsg s = [ParserError Nothing (Other s)] -} instance Error (ParserError p) where 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..."] mkParserError :: pos -> [ErrorMsg] -> [Either (ParserError pos) a] mkParserError pos e = [Left (ParserError (Just pos) e)] infix 0 -- | annotate a parse error with an additional 'Expect' message -- -- > satisfy isUpper 'an uppercase character' () :: Boomerang (ParserError p) tok a b -> String -> Boomerang (ParserError p) tok a b 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 = case bestErrors errs of [] -> ParserError Nothing [] errs'@(ParserError pos _ : _) -> ParserError pos (nub $ concatMap (\(ParserError _ e) -> e) errs') -- | Helper function for turning '[ErrorMsg]' into a user-friendly 'String' showErrorMessages :: String -> String -> String -> String -> String -> [ErrorMsg] -> String showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs | null msgs = msgUnknown | otherwise = intercalate ("; ") $ clean $ [showSysUnExpect, showUnExpect, showExpect, showMessages] where isSysUnExpect (SysUnExpect {}) = True isSysUnExpect _ = False isEOI (EOI {}) = True isEOI _ = False isUnExpect (UnExpect {}) = True isUnExpect _ = False isExpect (Expect {}) = True isExpect _ = False (sysUnExpect,msgs1) = span (\m -> isSysUnExpect m || isEOI m) (sort msgs) (unExpect ,msgs2) = span isUnExpect msgs1 (expect ,msgs3) = span isExpect msgs2 showExpect = showMany msgExpecting expect showUnExpect = showMany msgUnExpected unExpect showSysUnExpect | null sysUnExpect = "" | otherwise = let msg = head sysUnExpect in msgUnExpected ++ " " ++ if (isEOI msg) then msgEndOfInput ++ " " ++ (messageString $ head sysUnExpect) else messageString $ head sysUnExpect showMessages = showMany "" msgs3 showMany pre msgs = case clean (map messageString msgs) of [] -> "" ms | null pre -> commasOr ms | otherwise -> pre ++ " " ++ commasOr ms commasOr [] = "" commasOr [m] = m commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms commaSep = seperate ", " . clean seperate _ [] = "" seperate _ [m] = m seperate sep (m:ms) = m ++ sep ++ seperate sep ms clean = nub . filter (not . null) instance (Show pos) => Show (ParserError pos) where show e = showParserError show e -- | turn a parse error into a user-friendly error message showParserError :: (pos -> String) -- ^ function to turn the error position into a 'String' -> ParserError pos -- ^ the 'ParserError' -> String showParserError showPos (ParserError mPos msgs) = let posStr = case mPos of Nothing -> "unknown position" (Just pos) -> showPos pos in "parse error at " ++ posStr ++ ": " ++ (showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of" msgs) boomerang-1.4.5.2/Text/Boomerang/HStack.hs0000644000000000000000000000153312724634110016370 0ustar0000000000000000-- | a simple heteregenous stack library {-# LANGUAGE TypeOperators #-} module Text.Boomerang.HStack ( (:-)(..) , arg, hdTraverse, hdMap, hhead, htail, pop ) where infixr 8 :- -- | A stack datatype. Just a better looking tuple. data a :- b = a :- b deriving (Eq, Show) -- | Stack destructor. pop :: (a -> b -> r) -> (a :- b) -> r pop f (a :- b) = f a b -- | Get the top of the stack. hhead :: (a :- b) -> a hhead (a :- _) = a -- | Get the stack with the top popped. htail :: (a :- b) -> b htail (_ :- b) = b -- | Applicative traversal over the top of the stack. hdTraverse :: Functor f => (a -> f b) -> a :- t -> f (b :- t) hdTraverse f (a :- t) = fmap (:- t) (f a) arg :: (ty -> r -> s) -> (a -> ty) -> (a :- r) -> s arg c f = pop (c . f) -- | Map over the top of the stack. hdMap :: (a1 -> a2) -> (a1 :- b) -> (a2 :- b) hdMap = arg (:-) boomerang-1.4.5.2/Text/Boomerang/Pos.hs0000644000000000000000000000241412724634110015753 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Text.Boomerang.Pos ( Pos , InitialPosition(..) , ErrorPosition(..) , MajorMinorPos(..) , incMajor, incMinor ) where import Data.Data (Data, Typeable) -- | type synonym family that maps an error type to its position type type family Pos err :: * -- | extract the position information from an error class ErrorPosition err where getPosition :: err -> Maybe (Pos err) -- | the initial position for a position type class InitialPosition e where initialPos :: Maybe e -> Pos e -- | A basic 2-axis position type (e.g. line, character) data MajorMinorPos = MajorMinorPos { major :: Integer , minor :: Integer } deriving (Eq, Ord, Typeable, Data) -- | 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 -- | increment minor position by 'i' incMinor :: (Integral i) => i -> MajorMinorPos -> MajorMinorPos incMinor i (MajorMinorPos maj min) = MajorMinorPos maj (min + (fromIntegral i)) instance Show MajorMinorPos where show (MajorMinorPos s c) = "(" ++ show s ++ ", " ++ show c ++ ")" boomerang-1.4.5.2/Text/Boomerang/Prim.hs0000644000000000000000000001421212724634110016120 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeOperators, TypeFamilies #-} module Text.Boomerang.Prim ( -- * Types Parser(..), Boomerang(..), PrinterParser, (.~) -- * Running routers , parse, parse1, unparse, unparse1, bestErrors -- * Constructing / Manipulating Boomerangs , xpure, val, xmap -- heterogeneous list functions , xmaph ) where import Prelude hiding ((.), id) import Control.Arrow (first) import Control.Applicative (Applicative(..), Alternative(..)) import Control.Category (Category((.), id)) import Control.Monad (MonadPlus(mzero, mplus), ap) import Control.Monad.Error (Error(..)) import Data.Either (partitionEithers) import Data.Function (on) import Data.Monoid (Monoid(mappend, mempty)) import Text.Boomerang.HStack ((:-)(..), hdMap, hdTraverse) import Text.Boomerang.Pos (ErrorPosition(..), InitialPosition(..), Pos) compose :: (a -> b -> c) -> (i -> [(a, j)]) -> (j -> [(b, k)]) -> (i -> [(c, k)]) compose op mf mg s = do (f, s') <- mf s (g, s'') <- mg s' return (f `op` g, s'') -- | The 'maximumsBy' function takes a comparison function and a list -- and returns the greatest elements of the list by the comparison function. -- 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] -- |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) = Parser $ \tok pos -> map (fmap (first (first f))) (p tok pos) instance Applicative (Parser e tok) where pure = return (<*>) = ap instance Monad (Parser e tok) where return a = Parser $ \tok pos -> [Right ((a, tok), pos)] (Parser p) >>= f = Parser $ \tok pos -> case partitionEithers (p tok pos) of ([], []) -> [] (errs,[]) -> map Left errs (_,as) -> concat [ runParser (f a) tok' pos' | ((a, tok'), pos') <- as ] instance Alternative (Parser e tok) where empty = mzero (<|>) = mplus instance MonadPlus (Parser e tok) where mzero = Parser $ \tok pos -> [] (Parser x) `mplus` (Parser y) = Parser $ \tok pos -> (x tok pos) ++ (y tok pos) composeP :: (a -> b -> c) -> Parser e tok a -> Parser e tok b -> Parser e tok c 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 [] = [] bestErrors errs = maximumsBy (compare `on` getPosition) errs -- | A @Boomerang a b@ takes an @a@ to parse a URL and results in @b@ if parsing succeeds. -- And it takes a @b@ to serialize to a URL and results in @a@ if serializing succeeds. data Boomerang e tok a b = Boomerang { prs :: Parser e tok (a -> b) , ser :: b -> [(tok -> tok, a)] } type PrinterParser = Boomerang {-# DEPRECATED PrinterParser "Use Boomerang instead" #-} instance Category (Boomerang e tok) where id = Boomerang (return id) (\x -> [(id, x)]) ~(Boomerang pf sf) . ~(Boomerang pg sg) = Boomerang (composeP (.) pf pg) (compose (.) sf sg) instance Monoid (Boomerang e tok a b) where mempty = Boomerang mzero (const mzero) ~(Boomerang pf sf) `mappend` ~(Boomerang pg sg) = Boomerang (pf `mplus` pg) (\s -> sf s `mplus` sg s) infixr 9 .~ -- | Reverse composition, but with the side effects still in left-to-right order. (.~) :: Boomerang e tok a b -> Boomerang e tok b c -> Boomerang e tok a c ~(Boomerang pf sf) .~ ~(Boomerang pg sg) = Boomerang (composeP (flip (.)) pf pg) (compose (flip (.)) sg sf) -- | Map over routers. xmap :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok r a -> Boomerang e tok r b xmap f g (Boomerang p s) = Boomerang p' s' where p' = fmap (fmap f) p s' url = maybe mzero s (g url) -- | Lift a constructor-destructor pair to a pure router. xpure :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok a b xpure f g = xmap f g id -- | Like "xmap", but only maps over the top of the stack. xmaph :: (a -> b) -> (b -> Maybe a) -> Boomerang e tok i (a :- o) -> Boomerang e tok i (b :- o) xmaph f g = xmap (hdMap f) (hdTraverse g) -- | lift a 'Parser' and a printer into a 'Boomerang' val :: forall e tok a r. Parser e tok a -> (a -> [tok -> tok]) -> Boomerang e tok r (a :- r) val rs ss = Boomerang rs' ss' where rs' :: Parser e tok (r -> (a :- r)) rs' = fmap (:-) rs ss' = (\(a :- r) -> map (\f -> (f, r)) (ss a)) -- | Give all possible parses or errors. parse :: forall e a p tok. (InitialPosition e) => Boomerang e tok () a -> tok -> [Either e (a, tok)] parse p s = map (either Left (\((f, tok), _) -> Right (f (), tok))) $ runParser (prs p) s (initialPos (Nothing :: Maybe e)) -- | Give the first parse, for Boomerangs 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) -> Boomerang e tok () (a :- ()) -> tok -> Either [e] a parse1 isComplete r paths = let results = parse r paths in case [ a | (Right (a,tok)) <- results, isComplete tok ] of ((u :- ()):_) -> Right u _ -> Left $ bestErrors [ e | Left e <- results ] -- | Give all possible serializations. unparse :: tok -> Boomerang e tok () url -> url -> [tok] unparse tok p = (map (($ tok) . fst)) . ser p -- | Give the first serialization, for Boomerangs with a serializer that needs just one value. unparse1 :: tok -> Boomerang e tok () (a :- ()) -> a -> Maybe tok unparse1 tok p a = case unparse tok p (a :- ()) of [] -> Nothing (s:_) -> Just s boomerang-1.4.5.2/Text/Boomerang/String.hs0000644000000000000000000001115512724634110016462 0ustar0000000000000000-- | a 'Boomerang' library for working with a 'String' {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators #-} module Text.Boomerang.String ( -- * Types StringBoomerang, StringPrinterParser, StringError -- * Combinators , alpha, anyChar, char, digit, int , integer, lit, satisfy, space -- * Running the 'Boomerang' , isComplete, parseString, unparseString ) where import Prelude hiding ((.), id, (/)) import Control.Category (Category((.), id)) import Data.Char (isAlpha, isDigit, isSpace) import Data.Data (Data, Typeable) import Data.List (stripPrefix) import Data.String (IsString(..)) import Text.Boomerang.Combinators (opt, rCons, rList1) import Text.Boomerang.Error (ParserError(..),ErrorMsg(..), (), condenseErrors, mkParserError) import Text.Boomerang.HStack ((:-)(..)) import Text.Boomerang.Pos (InitialPosition(..), MajorMinorPos(..), incMajor, incMinor) import Text.Boomerang.Prim (Parser(..), Boomerang(..), parse1, xmaph, unparse1, val) type StringError = ParserError MajorMinorPos type StringBoomerang = Boomerang StringError String type StringPrinterParser = StringBoomerang {-# DEPRECATED StringPrinterParser "Use StringBoomerang instead" #-} instance InitialPosition StringError where initialPos _ = MajorMinorPos 0 0 -- | a constant string lit :: String -> StringBoomerang r r lit l = Boomerang pf sf where pf = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input", Expect (show l)] _ -> parseLit l tok pos sf b = [ (\string -> (l ++ string), b)] parseLit :: String -> String -> MajorMinorPos -> [Either StringError ((r -> r, String), MajorMinorPos)] parseLit [] ss pos = [Right ((id, ss), pos)] parseLit (l:_) [] pos = mkParserError pos [EOI "input", Expect (show l)] parseLit (l:ls) (s:ss) pos | l /= s = mkParserError pos [UnExpect (show s), Expect (show l)] | otherwise = parseLit ls ss (if l == '\n' then incMajor 1 pos else incMinor 1 pos) instance a ~ b => IsString (Boomerang StringError String a b) where fromString = lit -- | statisfy a 'Char' predicate satisfy :: (Char -> Bool) -> StringBoomerang r (Char :- r) satisfy p = val (Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] (c:cs) | p c -> do [Right ((c, cs), if (c == '\n') then incMajor 1 pos else incMinor 1 pos)] | otherwise -> do mkParserError pos [SysUnExpect $ show c] ) (\c -> [ \paths -> (c:paths) | p c ]) -- | ascii digits @\'0\'..\'9\'@ digit :: StringBoomerang r (Char :- r) digit = satisfy isDigit "a digit 0-9" -- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, -- plus letters of caseless scripts and modifiers letters). (Uses 'isAlpha') alpha :: StringBoomerang r (Char :- r) alpha = satisfy isAlpha "an alphabetic Unicode character" -- | matches white-space characters in the Latin-1 range. (Uses 'isSpace') space :: StringBoomerang r (Char :- r) space = satisfy isSpace "a white-space character" -- | any character anyChar :: StringBoomerang r (Char :- r) anyChar = satisfy (const True) -- | matches the specified character char :: Char -> StringBoomerang 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 :: StringBoomerang r (Int :- r) int = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit)) -- | matches an 'Integer' integer :: StringBoomerang r (Integer :- r) 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' -- -- see also: 'parseStrings' isComplete :: String -> Bool isComplete = null -- | run the parser -- -- Returns the first complete parse or a parse error. -- -- > parseString (rUnit . lit "foo") ["foo"] parseString :: StringBoomerang () (r :- ()) -> String -> Either StringError r parseString pp strs = either (Left . condenseErrors) Right $ parse1 isComplete pp strs -- | run the printer -- -- > unparseString (rUnit . lit "foo") () unparseString :: StringBoomerang () (r :- ()) -> r -> Maybe String unparseString pp r = unparse1 [] pp r boomerang-1.4.5.2/Text/Boomerang/Strings.hs0000644000000000000000000002110612724634110016642 0ustar0000000000000000-- | a 'Boomerang' library for working with '[String]' {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators #-} module Text.Boomerang.Strings ( -- * Types StringsError -- * Combinators , (), alpha, anyChar, anyString, char, digit, eos, int , integer, lit, readshow, satisfy, satisfyStr, space -- * Running the 'Boomerang' , isComplete, parseStrings, unparseStrings ) where import Prelude hiding ((.), id, (/)) import Control.Category (Category((.), id)) import Data.Char (isAlpha, isDigit, isSpace) import Data.Data (Data, Typeable) import Data.List (stripPrefix) import Data.String (IsString(..)) import Numeric (readDec, readSigned) import Text.Boomerang.Combinators (opt, rCons, rList1) import Text.Boomerang.Error (ParserError(..),ErrorMsg(..), (), condenseErrors, mkParserError) import Text.Boomerang.HStack ((:-)(..)) import Text.Boomerang.Pos (InitialPosition(..), MajorMinorPos(..), incMajor, incMinor) import Text.Boomerang.Prim (Parser(..), Boomerang(..), parse1, xmaph, unparse1, val) type StringsError = ParserError MajorMinorPos instance InitialPosition StringsError where initialPos _ = MajorMinorPos 0 0 instance a ~ b => IsString (Boomerang StringsError [String] a b) where fromString = lit -- | a constant string lit :: String -> Boomerang StringsError [String] r r lit l = Boomerang pf sf where pf = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input", Expect (show l)] ("":_) | (not $ null l) -> mkParserError pos [EOI "segment", Expect (show l)] (p:ps) -> case stripPrefix l p of (Just p') -> do [Right ((id, p':ps), incMinor (length l) pos)] Nothing -> mkParserError pos [UnExpect (show p), Expect (show l)] sf b = [ (\strings -> case strings of [] -> [l] ; (s:ss) -> ((l ++ s) : ss), b)] infixr 9 -- | equivalent to @f . eos . g@ () :: Boomerang StringsError [String] b c -> Boomerang StringsError [String] a b -> Boomerang StringsError [String] a c f g = f . eos . g -- | end of string eos :: Boomerang StringsError [String] r r eos = Boomerang (Parser $ \path pos -> case path of [] -> [Right ((id, []), incMajor 1 pos)] -- [] -> mkParserError pos [EOI "input"] ("":ps) -> [ Right ((id, ps), incMajor 1 pos) ] (p:_) -> mkParserError pos [Message $ "path-segment not entirely consumed: " ++ p]) (\a -> [(("" :), a)]) -- | statisfy a 'Char' predicate satisfy :: (Char -> Bool) -> Boomerang StringsError [String] r (Char :- r) satisfy p = val (Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] ("":ss) -> mkParserError pos [EOI "segment"] ((c:cs):ss) | p c -> do [Right ((c, cs : ss), incMinor 1 pos )] | otherwise -> do mkParserError pos [SysUnExpect $ show c] ) (\c -> [ \paths -> case paths of [] -> [[c]] ; (s:ss) -> ((c:s):ss) | p c ]) -- | satisfy a 'String' predicate. -- -- Note: must match the entire remainder of the 'String' in this segment satisfyStr :: (String -> Bool) -> Boomerang StringsError [String] r (String :- r) satisfyStr p = val (Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] ("":ss) -> mkParserError pos [EOI "segment"] (s:ss) | p s -> do [Right ((s, "":ss), incMajor 1 pos )] | otherwise -> do mkParserError pos [SysUnExpect $ show s] ) (\str -> [ \strings -> case strings of [] -> [str] ; (s:ss) -> ((str++s):ss) | p str ]) -- | ascii digits @\'0\'..\'9\'@ digit :: Boomerang StringsError [String] r (Char :- r) digit = satisfy isDigit "a digit 0-9" -- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, -- plus letters of caseless scripts and modifiers letters). (Uses 'isAlpha') alpha :: Boomerang StringsError [String] r (Char :- r) alpha = satisfy isAlpha "an alphabetic Unicode character" -- | matches white-space characters in the Latin-1 range. (Uses 'isSpace') space :: Boomerang StringsError [String] r (Char :- r) space = satisfy isSpace "a white-space character" -- | any character anyChar :: Boomerang StringsError [String] r (Char :- r) anyChar = satisfy (const True) -- | matches the specified character char :: Char -> Boomerang StringsError [String] r (Char :- r) char c = satisfy (== c) show [c] -- | lift 'Read'/'Show' to a 'Boomerang' -- -- 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) => Boomerang 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, Real a) => String -> a readIntegral s = case (readSigned readDec) 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 :: Boomerang StringsError [String] r (Int :- r) 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 :: Boomerang StringsError [String] r (Integer :- r) integer = xmaph readIntegral (Just . show) (opt (rCons . char '-') . (rList1 digit)) -- | matches any 'String' -- -- the parser returns the remainder of the current String segment, (but does not consume the 'end of segment'. -- -- Note that the only combinator that should follow 'anyString' is -- 'eos' or ''. Other combinators will lead to inconsistent -- inversions. -- -- For example, if we have: -- -- > unparseStrings (rPair . anyString . anyString) ("foo","bar") -- -- That will unparse to @Just ["foobar"]@. But if we call -- -- > parseStrings (rPair . anyString . anyString) ["foobar"] -- -- We will get @Right ("foobar","")@ instead of the original @Right ("foo","bar")@ anyString :: Boomerang StringsError [String] r (String :- r) anyString = val ps ss where ps = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input", Expect "any string"] -- ("":_) -> mkParserError pos [EOI "segment", Expect "any string"] (s:ss) -> [Right ((s, "":ss), incMinor (length s) pos)] ss str = [\ss -> case ss of [] -> [str] (s:ss') -> ((str ++ s) : ss') ] -- | Predicate to test if we have parsed all the strings. -- Typically used as argument to 'parse1' -- -- see also: 'parseStrings' isComplete :: [String] -> Bool isComplete [] = True isComplete [""] = True isComplete _ = False -- | run the parser -- -- Returns the first complete parse or a parse error. -- -- > parseStrings (rUnit . lit "foo") ["foo"] parseStrings :: Boomerang StringsError [String] () (r :- ()) -> [String] -> Either StringsError r parseStrings pp strs = either (Left . condenseErrors) Right $ parse1 isComplete pp strs -- | run the printer -- -- > unparseStrings (rUnit . lit "foo") () unparseStrings :: Boomerang e [String] () (r :- ()) -> r -> Maybe [String] unparseStrings pp r = unparse1 [] pp rboomerang-1.4.5.2/Text/Boomerang/Texts.hs0000644000000000000000000002475212724634110016332 0ustar0000000000000000-- | a 'Boomerang' library for working with '[Text]' {-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators #-} module Text.Boomerang.Texts ( -- * Types TextsError -- * Combinators , (), alpha, anyChar, anyText, char, digit, digits, signed, eos, integral, int , integer, lit, readshow, satisfy, satisfyStr, space , rTextCons, rEmpty, rText, rText1 -- * Running the 'Boomerang' , isComplete, parseTexts, unparseTexts ) where import Prelude hiding ((.), id, (/)) import Control.Category (Category((.), id)) import Data.Char (isAlpha, isDigit, isSpace) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Read as Text import Text.Boomerang.Combinators (opt, duck1, manyr, somer) import Text.Boomerang.Error (ParserError(..),ErrorMsg(..), (), condenseErrors, mkParserError) import Text.Boomerang.HStack ((:-)(..), arg) import Text.Boomerang.Pos (InitialPosition(..), MajorMinorPos(..), incMajor, incMinor) import Text.Boomerang.Prim (Parser(..), Boomerang(..), parse1, xmaph, xpure, unparse1, val) type TextsError = ParserError MajorMinorPos instance InitialPosition TextsError where initialPos _ = MajorMinorPos 0 0 instance a ~ b => IsString (Boomerang TextsError [Text] a b) where fromString = lit . Text.pack -- | a constant string lit :: Text -> Boomerang TextsError [Text] r r lit l = Boomerang pf sf where pf = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input", Expect (show l)] (p:ps) | Text.null p && (not $ Text.null l) -> mkParserError pos [EOI "segment", Expect (show l)] | otherwise -> case Text.stripPrefix l p of (Just p') -> [Right ((id, p':ps), incMinor (Text.length l) pos)] Nothing -> mkParserError pos [UnExpect (show p), Expect (show l)] sf b = [ (\strings -> case strings of [] -> [l] ; (s:ss) -> ((l `Text.append` s) : ss), b)] infixr 9 -- | equivalent to @f . eos . g@ () :: Boomerang TextsError [Text] b c -> Boomerang TextsError [Text] a b -> Boomerang TextsError [Text] a c f g = f . eos . g -- | end of string eos :: Boomerang TextsError [Text] r r eos = Boomerang (Parser $ \path pos -> case path of [] -> [Right ((id, []), incMajor 1 pos)] -- [] -> mkParserError pos [EOI "input"] (p:ps) | Text.null p -> [ Right ((id, ps), incMajor 1 pos) ] | otherwise -> mkParserError pos [Message $ "path-segment not entirely consumed: " ++ (Text.unpack p)]) (\a -> [((Text.empty :), a)]) -- | statisfy a 'Char' predicate satisfy :: (Char -> Bool) -> Boomerang TextsError [Text] r (Char :- r) satisfy p = val (Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] (s:ss) -> case Text.uncons s of Nothing -> mkParserError pos [EOI "segment"] (Just (c, cs)) | p c -> [Right ((c, cs : ss), incMinor 1 pos )] | otherwise -> mkParserError pos [SysUnExpect $ show c] ) (\c -> [ \paths -> case paths of [] -> [Text.singleton c] ; (s:ss) -> ((Text.cons c s):ss) | p c ]) -- | satisfy a 'Text' predicate. -- -- Note: must match the entire remainder of the 'Text' in this segment satisfyStr :: (Text -> Bool) -> Boomerang TextsError [Text] r (Text :- r) satisfyStr p = val (Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] (s:ss) | Text.null s -> mkParserError pos [EOI "segment"] | p s -> do [Right ((s, Text.empty:ss), incMajor 1 pos )] | otherwise -> do mkParserError pos [SysUnExpect $ show s] ) (\str -> [ \strings -> case strings of [] -> [str] ; (s:ss) -> ((str `Text.append` s):ss) | p str ]) -- | ascii digits @\'0\'..\'9\'@ digit :: Boomerang TextsError [Text] r (Char :- r) digit = satisfy isDigit "a digit 0-9" -- | matches alphabetic Unicode characters (lower-case, upper-case and title-case letters, -- plus letters of caseless scripts and modifiers letters). (Uses 'isAlpha') alpha :: Boomerang TextsError [Text] r (Char :- r) alpha = satisfy isAlpha "an alphabetic Unicode character" -- | matches white-space characters in the Latin-1 range. (Uses 'isSpace') space :: Boomerang TextsError [Text] r (Char :- r) space = satisfy isSpace "a white-space character" -- | any character anyChar :: Boomerang TextsError [Text] r (Char :- r) anyChar = satisfy (const True) -- | matches the specified character char :: Char -> Boomerang TextsError [Text] r (Char :- r) char c = satisfy (== c) show [c] -- | lift 'Read'/'Show' to a 'Boomerang' -- -- 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) => Boomerang TextsError [Text] r (a :- r) readshow = val readParser s where s a = [ \strings -> case strings of [] -> [Text.pack $ show a] ; (s:ss) -> (((Text.pack $ show a) `Text.append` s):ss) ] readParser :: (Read a) => Parser TextsError [Text] a readParser = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input"] (p:_) | Text.null p -> mkParserError pos [EOI "segment"] (p:ps) -> case reads (Text.unpack p) of [] -> mkParserError pos [SysUnExpect (Text.unpack p), Message $ "decoding using 'read' failed."] [(a,r)] -> [Right ((a, (Text.pack r):ps), incMinor ((Text.length p) - (length r)) pos)] readIntegral :: (Integral a) => Text -> a readIntegral s = case (Text.signed Text.decimal) s of (Left e) -> error $ "readIntegral: " ++ e (Right (a, r)) | Text.null r -> a | otherwise -> error $ "readIntegral: ambiguous parse. Left over data: " ++ Text.unpack r -- | the empty string rEmpty :: Boomerang e [Text] r (Text :- r) rEmpty = xpure (Text.empty :-) $ \(xs :- t) -> if Text.null xs then (Just t) else Nothing -- | the first character of a 'Text' rTextCons :: Boomerang e tok (Char :- Text :- r) (Text :- r) rTextCons = xpure (arg (arg (:-)) (Text.cons)) $ \(xs :- t) -> do (a, as) <- Text.uncons xs return (a :- as :- t) -- | construct/parse some 'Text' by repeatedly apply a 'Char' 0 or more times parser rText :: Boomerang e [Text] r (Char :- r) -> Boomerang e [Text] r (Text :- r) rText r = manyr (rTextCons . duck1 r) . rEmpty -- | construct/parse some 'Text' by repeatedly apply a 'Char' 1 or more times parser rText1 :: Boomerang e [Text] r (Char :- r) -> Boomerang e [Text] r (Text :- r) rText1 r = somer (rTextCons . duck1 r) . rEmpty -- | a sequence of one or more digits digits :: Boomerang TextsError [Text] r (Text :- r) digits = rText1 digit -- | an optional - character -- -- Typically used with 'digits' to support signed numbers -- -- > signed digits signed :: Boomerang TextsError [Text] a (Text :- r) -> Boomerang TextsError [Text] a (Text :- r) signed r = opt (rTextCons . char '-') . r -- | matches an 'Integral' value -- -- Note that the combinator @(rPair . integral . integral)@ is ill-defined because the parse canwell. not tell where it is supposed to split the sequence of digits to produced two ints. integral :: (Integral a, Show a) => Boomerang TextsError [Text] r (a :- r) integral = xmaph readIntegral (Just . Text.pack . show) (signed digits) -- | matches an 'Int' -- Note that the combinator @(rPair . int . int)@ is ill-defined because the parse canwell. not tell where it is supposed to split the sequence of digits to produced two ints. int :: Boomerang TextsError [Text] r (Int :- r) int = integral -- | 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 :: Boomerang TextsError [Text] r (Integer :- r) integer = integral -- | matches any 'Text' -- -- the parser returns the remainder of the current Text segment, (but does not consume the 'end of segment'. -- -- Note that the only combinator that should follow 'anyText' is -- 'eos' or ''. Other combinators will lead to inconsistent -- inversions. -- -- For example, if we have: -- -- > unparseTexts (rPair . anyText . anyText) ("foo","bar") -- -- That will unparse to @Just ["foobar"]@. But if we call -- -- > parseTexts (rPair . anyText . anyText) ["foobar"] -- -- We will get @Right ("foobar","")@ instead of the original @Right ("foo","bar")@ anyText :: Boomerang TextsError [Text] r (Text :- r) anyText = val ps ss where ps = Parser $ \tok pos -> case tok of [] -> mkParserError pos [EOI "input", Expect "any string"] -- ("":_) -> mkParserError pos [EOI "segment", Expect "any string"] (s:ss) -> [Right ((s, Text.empty:ss), incMinor (Text.length s) pos)] ss str = [\ss -> case ss of [] -> [str] (s:ss') -> ((str `Text.append` s) : ss') ] -- | Predicate to test if we have parsed all the Texts. -- Typically used as argument to 'parse1' -- -- see also: 'parseTexts' isComplete :: [Text] -> Bool isComplete [] = True isComplete [t] = Text.null t isComplete _ = False -- | run the parser -- -- Returns the first complete parse or a parse error. -- -- > parseTexts (rUnit . lit "foo") ["foo"] parseTexts :: Boomerang TextsError [Text] () (r :- ()) -> [Text] -> Either TextsError r parseTexts pp strs = either (Left . condenseErrors) Right $ parse1 isComplete pp strs -- | run the printer -- -- > unparseTexts (rUnit . lit "foo") () unparseTexts :: Boomerang e [Text] () (r :- ()) -> r -> Maybe [Text] unparseTexts pp r = unparse1 [] pp r boomerang-1.4.5.2/Text/Boomerang/TH.hs0000644000000000000000000001021412724634110015522 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-} module Text.Boomerang.TH ( makeBoomerangs -- * Backwards-compatibility , derivePrinterParsers ) where import Control.Monad (liftM, replicateM) import Language.Haskell.TH import Text.Boomerang.HStack ((:-)(..), arg) import Text.Boomerang.Prim (xpure, Boomerang) -- | Make a 'Boomerang' router for each constructor in a datatype. For -- example: -- -- @$(makeBoomerangs \'\'Sitemap)@ makeBoomerangs :: Name -> Q [Dec] makeBoomerangs name = do info <- reify name case info of #if MIN_VERSION_template_haskell(2,11,0) TyConI (DataD _ tName tBinds _ cons _) -> #else TyConI (DataD _ tName tBinds cons _) -> #endif concat `liftM` mapM (deriveBoomerang (tName, tBinds)) cons #if MIN_VERSION_template_haskell(2,11,0) TyConI (NewtypeD _ tName tBinds _ con _) -> #else TyConI (NewtypeD _ tName tBinds con _) -> #endif deriveBoomerang (tName, tBinds) con _ -> fail $ show name ++ " is not a datatype." -- | Old name for 'makeBoomerangs', since renamed to reflect the fact -- that it's not actually deriving instances for any type class, but rather -- generates top-level definitions for routers of type 'Boomerang'. derivePrinterParsers :: Name -> Q [Dec] derivePrinterParsers = makeBoomerangs {-# DEPRECATED derivePrinterParsers "Use makeBoomerangs instead" #-} -- Derive a router for a single constructor. deriveBoomerang :: (Name, [TyVarBndr]) -> Con -> Q [Dec] deriveBoomerang (tName, tParams) con = case con of NormalC name tys -> go name (map snd tys) RecC name tys -> go name (map (\(_,_,ty) -> ty) tys) _ -> do runIO $ putStrLn $ "Skipping unsupported constructor " ++ show (conName con) return [] where takeName (PlainTV n) = n takeName (KindedTV n _) = n go name tys = do let name' = mkBoomerangName name let tok' = mkName "tok" let e' = mkName "e" let ppType = AppT (AppT (ConT ''Boomerang) (VarT e')) (VarT tok') let r' = mkName "r" let inT = foldr (\a b -> AppT (AppT (ConT ''(:-)) a) b) (VarT r') tys let outT = AppT (AppT (ConT ''(:-)) (foldl AppT (ConT tName) (map (VarT . takeName) tParams))) (VarT r') -- runIO $ putStrLn $ "Introducing router " ++ nameBase name' ++ "." expr <- [| xpure $(deriveConstructor name (length tys)) $(deriveDestructor name tys) |] return [ SigD name' (ForallT (map PlainTV ([tok', e', r'] ++ (map takeName tParams))) [] (AppT (AppT ppType inT) outT)) , FunD name' [Clause [] (NormalB expr) []] ] -- Derive the contructor part of a router. deriveConstructor :: Name -> Int -> Q Exp deriveConstructor name arity = [| $(mk arity) $(conE name) |] where mk :: Int -> ExpQ mk 0 = [| (:-) |] mk n = [| arg $(mk (n - 1)) |] -- Derive the destructor part of a router. deriveDestructor :: Name -> [Type] -> Q Exp deriveDestructor name tys = do -- Introduce some names x <- newName "x" r <- newName "r" fieldNames <- replicateM (length tys) (newName "a") -- Figure out the names of some constructors nothing <- [| Nothing |] ConE just <- [| Just |] ConE left <- [| Left |] ConE right <- [| Right |] ConE cons <- [| (:-) |] let conPat = ConP name (map VarP fieldNames) let okBody = ConE just `AppE` foldr (\h t -> ConE cons `AppE` VarE h `AppE` t) (VarE r) fieldNames let okCase = Match (ConP cons [conPat, VarP r]) (NormalB okBody) [] let nStr = show name let failCase = Match WildP (NormalB nothing) [] return $ LamE [VarP x] (CaseE (VarE x) [okCase, failCase]) -- Derive the name of a router based on the name of the constructor in question. mkBoomerangName :: Name -> Name mkBoomerangName name = mkName ('r' : nameBase name) -- Retrieve the name of a constructor. conName :: Con -> Name conName con = case con of NormalC name _ -> name RecC name _ -> name InfixC _ name _ -> name ForallC _ _ con' -> conName con'