packages feed

boomerang (empty) → 1.0.0

raw patch · 12 files changed

+1111/−0 lines, 12 filesdep +basedep +mtldep +template-haskellsetup-changed

Dependencies added: base, mtl, template-haskell, web-routes

Files

+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Boomerang.hs view
@@ -0,0 +1,133 @@+{-|++ 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:++<http://hackage.haskell.org/package/Zwaluw>++Boomerang is similar in purpose, but different in implementation to:++<http://hackage.haskell.org/package/invertible-syntax>++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 derive some combinators for the type:++> $(derivePrinterParsers ''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 :: StringPrinterParser () (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+
+ Text/Boomerang/Combinators.hs view
@@ -0,0 +1,149 @@+-- | a collection of generic parsing combinators that can work with any token and error type.+{-# LANGUAGE 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 Data.Monoid         (Monoid(mappend))+import Text.Boomerang.Prim    (Parser(..), PrinterParser(..), (.~), val, xpure)+import Text.Boomerang.HStack   ((:-)(..), arg, hhead)+import Text.Boomerang.TH      (derivePrinterParsers)++infixr 8 <>++-- | Infix operator for 'mappend'.+(<>) :: Monoid m => m -> m -> m+(<>) = mappend++-- | Convert a router to do what it does on the tail of the stack.+duck :: PrinterParser e tok r1 r2 -> PrinterParser e tok (h :- r1) (h :- r2)+duck r = PrinterParser+  (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 :: PrinterParser e tok r1 (a :- r2) -> PrinterParser e tok (h :- r1) (a :- h :- r2)+duck1 r = PrinterParser+  (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 :: PrinterParser e tok r r -> PrinterParser e tok r r+opt = (id <>)++-- | Repeat a router zero or more times, combining the results from left to right.+manyr :: PrinterParser e tok r r -> PrinterParser e tok r r+manyr = opt . somer++-- | Repeat a router one or more times, combining the results from left to right.+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@. +--   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@. +--   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++-- | Repeat a router zero or more times, combining the results from right to left.+manyl :: PrinterParser e tok r r -> PrinterParser e tok r r+manyl = opt . somel++-- | Repeat a router one or more times, combining the results from right to left.+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@. +--   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@. +--   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 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 :: PrinterParser e [tok] a b -> tok -> PrinterParser 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 -> PrinterParser e tok r (a :- r)+push a = xpure (a :-) (\(a' :- t) -> guard (a' == a) >> Just t)++rNil :: PrinterParser e tok r ([a] :- r)+rNil = xpure ([] :-) $ \(xs :- t) -> do [] <- Just xs; Just t++rCons :: PrinterParser 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 :: PrinterParser e tok r (a :- r) -> PrinterParser 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 :: PrinterParser e tok r (a :- r) -> PrinterParser 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 :: PrinterParser e tok r (a :- r) -> PrinterParser e tok ([a] :- r) ([a] :- r) -> PrinterParser e tok r ([a] :- r)+rListSep r sep = chainr (rCons . duck1 r) sep . rNil++rPair :: PrinterParser e tok (f :- s :- r) ((f, s) :- r)+rPair = xpure (arg (arg (:-)) (,)) $ \(ab :- t) -> do (a,b) <- Just ab; Just (a :- b :- t)++$(derivePrinterParsers ''Either)+rLeft  :: PrinterParser e tok (a :- r) (Either a b :- r)+rRight :: PrinterParser e tok (b :- r) (Either a b :- r)++-- | Combines a router for a value @a@ and a router for a value @b@ into a router for @Either a b@.+rEither :: PrinterParser e tok r (a :- r) -> PrinterParser e tok r (b :- r) -> PrinterParser e tok r (Either a b :- r)+rEither l r = rLeft . l <> rRight . r++$(derivePrinterParsers ''Maybe)+rNothing :: PrinterParser e tok       r  (Maybe a :- r)+rJust    :: PrinterParser e tok (a :- r) (Maybe a :- r)++-- | Converts a router for a value @a@ to a router for a @Maybe a@.+rMaybe :: PrinterParser e tok r (a :- r) -> PrinterParser e tok r (Maybe a :- r)+rMaybe r = rJust . r <> rNothing++$(derivePrinterParsers ''Bool)+rTrue  :: PrinterParser e tok r (Bool :- r)+rFalse :: PrinterParser e tok r (Bool :- r)++rBool :: PrinterParser e tok a r -- ^ 'True' parser+      -> PrinterParser e tok a r -- ^ 'False' parser+      -> PrinterParser e tok a (Bool :- r)+rBool t f = rTrue . t <> rFalse . f++rUnit :: PrinterParser e tok r (() :- r)+rUnit = xpure ((:-) ()) (\ (() :- x) -> Just x)
+ Text/Boomerang/Error.hs view
@@ -0,0 +1,132 @@+-- | An Error handling scheme that can be used with 'PrinterParser'+{-# 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'+(<?>) :: PrinterParser (ParserError p) tok a b -> String -> PrinterParser (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)
+ Text/Boomerang/HStack.hs view
@@ -0,0 +1,34 @@+-- | 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 (:-)+
+ Text/Boomerang/Pos.hs view
@@ -0,0 +1,41 @@+{-# 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 ++ ")"
+ Text/Boomerang/Prim.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeOperators, TypeFamilies #-}+module Text.Boomerang.Prim+    ( -- * Types+    Parser(..), PrinterParser(..), (.~)+    -- * Running routers+    , parse, parse1, unparse, unparse1, bestErrors+    -- * Constructing / Manipulating PrinterParsers+    , xpure, val, xmap+    -- heterogeneous list functions+    , xmaph+    ) where++import Prelude             hiding ((.), id)+import Control.Arrow       (first)+import Control.Category    (Category((.), id))+import Control.Monad       (MonadPlus(mzero, mplus))+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 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 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 @PrinterParser 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 PrinterParser e tok a b = PrinterParser+  { prs :: Parser e tok (a -> b)+  , ser :: b -> [(tok -> tok, a)]+  }++instance Category (PrinterParser e tok) where+  id = PrinterParser+    (return id)+    (\x -> [(id, x)])++  ~(PrinterParser pf sf) . ~(PrinterParser pg sg) = PrinterParser +    (composeP (.) pf pg)+    (compose (.) sf sg) ++instance Monoid (PrinterParser e tok a b) where+  mempty = PrinterParser +    mzero+    (const mzero)++  ~(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 +  (composeP (flip (.)) pf pg)+  (compose (flip (.)) sg sf)++-- | Map over routers.+xmap :: (a -> b) -> (b -> Maybe a) -> PrinterParser e tok r a -> PrinterParser e tok r b+xmap f g (PrinterParser p s) = PrinterParser 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) -> PrinterParser 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) -> PrinterParser e tok i (a :- o) -> PrinterParser e tok i (b :- o)+xmaph f g = xmap (hdMap f) (hdTraverse g)++-- | lift a 'Parser' and a printer into a 'PrinterParser'+val :: forall e tok a r. Parser e tok a -> (a -> [tok -> tok]) -> PrinterParser e tok r (a :- r)+val rs ss = PrinterParser 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) => PrinterParser 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 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 = +    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 -> PrinterParser e tok () url -> url -> [tok]+unparse tok p = (map (($ tok) . fst)) . ser p++-- | 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 = +    case unparse tok p (a :- ()) of+      [] -> Nothing+      (s:_) -> Just s
+ Text/Boomerang/String.hs view
@@ -0,0 +1,119 @@+-- | a 'PrinterParser' library for working with a 'String'+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators #-}+module Text.Boomerang.String+    (+    -- * Types+      StringPrinterParser, StringError+    -- * Combinators+    , alpha, anyChar, char, digit, int+    , integer, lit, satisfy, space+    -- * Running the 'PrinterParser'+    , 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(..), PrinterParser(..), parse1, xmaph, unparse1, val)++type StringError         = ParserError MajorMinorPos+type StringPrinterParser = PrinterParser StringError String++instance InitialPosition StringError where+    initialPos _ = MajorMinorPos 0 0+++-- | a constant string+lit :: String -> StringPrinterParser r r+lit l = PrinterParser 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 (PrinterParser StringError String a b) where+    fromString = lit++-- | statisfy a 'Char' predicate+satisfy :: (Char -> Bool) -> StringPrinterParser 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 :: StringPrinterParser 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 :: StringPrinterParser r (Char :- r)+alpha = satisfy isAlpha <?> "an alphabetic Unicode character"++-- | matches white-space characters in the Latin-1 range. (Uses 'isSpace')+space :: StringPrinterParser r (Char :- r)+space = satisfy isSpace <?> "a white-space character"++-- | any character+anyChar :: StringPrinterParser r (Char :- r)+anyChar = satisfy (const True)++-- | matches the specified character+char :: Char -> StringPrinterParser r (Char :- r)+char c = satisfy (== c) <?> show [c]++-- | matches an 'Int'+int :: StringPrinterParser r (Int :- r)+int = xmaph read (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))++-- | 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 :: StringPrinterParser () (r :- ())+             -> String+             -> Either StringError r+parseString pp strs = +    either (Left . condenseErrors) Right $ parse1 isComplete pp strs++-- | run the printer+--+-- > unparseString (rUnit . lit "foo") ()+unparseString :: StringPrinterParser () (r :- ()) -> r -> Maybe String+unparseString pp r = unparse1 [] pp r
+ Text/Boomerang/Strings.hs view
@@ -0,0 +1,166 @@+-- | a 'PrinterParser' 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, satisfy, satisfyStr, space+    -- * Running the 'PrinterParser'+    , 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 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(..), PrinterParser(..), parse1, xmaph, unparse1, val)++type StringsError = ParserError MajorMinorPos++instance InitialPosition StringsError where+    initialPos _ = MajorMinorPos 0 0++instance a ~ b => IsString (PrinterParser StringsError [String] a b) where+    fromString = lit++-- | a constant string+lit :: String -> PrinterParser StringsError [String] r r+lit l = PrinterParser 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@+(</>) :: PrinterParser StringsError [String] b c -> PrinterParser StringsError [String] a b -> PrinterParser StringsError [String] a c+f </> g = f . eos . g++-- | end of string+eos :: PrinterParser StringsError [String] r r+eos = PrinterParser +       (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) -> PrinterParser 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) -> PrinterParser 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 :: 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, +-- plus letters of caseless scripts and modifiers letters).  (Uses 'isAlpha')+alpha :: PrinterParser StringsError [String] r (Char :- r)+alpha = satisfy isAlpha <?> "an alphabetic Unicode character"++-- | matches white-space characters in the Latin-1 range. (Uses 'isSpace')+space :: PrinterParser StringsError [String] r (Char :- r)+space = satisfy isSpace <?> "a white-space character"++-- | any character+anyChar :: PrinterParser StringsError [String] r (Char :- r)+anyChar = satisfy (const True)++-- | matches the specified character+char :: Char -> PrinterParser StringsError [String] r (Char :- r)+char c = satisfy (== c) <?> show [c]++-- | matches an 'Int'+int :: PrinterParser StringsError [String] r (Int :- r)+int = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))++-- | matches an 'Integer'+integer :: PrinterParser StringsError [String] r (Integer :- r)+integer = xmaph read (Just . show) (opt (rCons . char '-') . (rList1 digit))++-- | matches any 'String'+anyString :: PrinterParser 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), incMajor 1 pos)]+      ss str = [\ss -> str : 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 :: PrinterParser 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 :: PrinterParser e [String] () (r :- ()) -> r -> Maybe [String]+unparseStrings pp r = unparse1 [] pp r
+ Text/Boomerang/TH.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Text.Boomerang.TH (derivePrinterParsers) where++import Control.Monad       (liftM, replicateM)+import Language.Haskell.TH +import Text.Boomerang.HStack   ((:-)(..), arg)+import Text.Boomerang.Prim    (xpure)++-- | Derive routers for all constructors in a datatype. For example: +--+--   @$(derivePrinterParsers \'\'Sitemap)@+derivePrinterParsers :: Name -> Q [Dec]+derivePrinterParsers name = do+  info <- reify name+  case info of+    TyConI (DataD _ _ _ cons _)   ->+      concat `liftM` mapM derivePrinterParser cons+    TyConI (NewtypeD _ _ _ con _) ->+      derivePrinterParser con+    _ ->+      fail $ show name ++ " is not a datatype."++-- Derive a router for a single constructor.+derivePrinterParser :: Con -> Q [Dec]+derivePrinterParser 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+    go name tys = do+      let name' = mkPrinterParserName name+      runIO $ putStrLn $ "Introducing router " ++ nameBase name' ++ "."+      expr <- [| xpure $(deriveConstructor name (length tys))+                     $(deriveDestructor name tys) |]+      return [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.+mkPrinterParserName :: Name -> Name+mkPrinterParserName 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'
+ boomerang.cabal view
@@ -0,0 +1,43 @@+Name:             boomerang+Version:          1.0.0+License:          BSD3+License-File:     LICENSE+Author:           jeremy@seereason.com+Maintainer:       partners@seereason.com+Bug-Reports:      http://bugzilla.seereason.com/+Category:         Parsing, Text+Synopsis:         Library for invertible parsing and printing+Description:      Specify single unified grammar which can be used for parsing and pretty-printing+Cabal-Version:    >= 1.6+Build-type:       Simple++Library+        Build-Depends:    base >= 4 && < 5,+                          mtl,+                          web-routes,+                          template-haskell+        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.TH++        Extensions:       DeriveDataTypeable,+                          FlexibleContexts,+                          FlexibleContexts,+                          FlexibleInstances,+                          RankNTypes,+                          ScopedTypeVariables,+                          TemplateHaskell,+                          TypeFamilies,+                          TypeFamilies,+                          TypeOperators,+                          TypeSynonymInstances++source-repository head+    type:     darcs+    location: http://src.seereason.com/web-routes/