diff --git a/src/Text/ParserCombinators/UU/BasicInstances.hs b/src/Text/ParserCombinators/UU/BasicInstances.hs --- a/src/Text/ParserCombinators/UU/BasicInstances.hs +++ b/src/Text/ParserCombinators/UU/BasicInstances.hs @@ -15,6 +15,7 @@ module Text.ParserCombinators.UU.BasicInstances where import Text.ParserCombinators.UU.Core import Data.List +import Debug.Trace data Error pos = Inserted String pos Strings | Deleted String pos Strings @@ -60,7 +61,8 @@ True )) in case tts of (t:ts) -> if p t - then Step 1 (k t (Str ts msgs (advance pos t) True)) + then show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n") + (Step 1 (k t (Str ts msgs (advance pos t) True))) else Fail [msg] (ins: if del_ok then [del] else []) [] -> Fail [msg] [ins] @@ -84,18 +86,21 @@ -- pMunch -data Munch a = Munch (a -> Bool) +data Munch a = Munch (a -> Bool) String instance (Show a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Munch a) [a] where - splitState (Munch p) k inp@(Str tts msgs pos del_ok) + splitState (Munch p x) k inp@(Str tts msgs pos del_ok) = let (munched, rest) = span p tts l = length munched - in if l > 0 then Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok))) - else k [] inp + in if l > 0 then show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") + (Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok)))) + else show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") (k [] inp) pMunch :: (Provides st (Munch a) [a]) => (a -> Bool) -> P st [a] -pMunch p = pSymExt Zero (Just []) (Munch p) +pMunch p = pSymExt Zero Nothing (Munch p "") -- the empty case is handled above +pMunchL p l = pSymExt Zero Nothing (Munch p l) -- the empty case is handled above + data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token instance (Show a, Eq a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Token a) [a] where @@ -107,7 +112,8 @@ del exp = (5, splitState tok k (Str (tail tts) (msgs ++ [Deleted (show(head tts)) pos exp]) (advance pos [(head tts)]) True )) in if null tts then Fail [msg] [ins] else Fail [msg] (ins: if del_ok then [del] else []) - Just rest -> Step l (k as (Str rest msgs (advance pos as) True)) + Just rest -> show_tokens ("Accepting token: " ++ show as ++"\n") + (Step l (k as (Str rest msgs (advance pos as) True))) pToken as = pTokenCost as 5 pTokenCost as c = if null as then error "call to pToken with empty token" @@ -115,6 +121,6 @@ where length [] = Zero length (_:as) = Succ (length as) - - - +show_tokens m v = {- trace m-} v +show_munch m v = {- trace m-} v +show_symbol m v = {- trace m-} v diff --git a/src/Text/ParserCombinators/UU/CHANGELOG.hs b/src/Text/ParserCombinators/UU/CHANGELOG.hs --- a/src/Text/ParserCombinators/UU/CHANGELOG.hs +++ b/src/Text/ParserCombinators/UU/CHANGELOG.hs @@ -1,10 +1,21 @@ -- | This module just contains the CHANGELOG -- +-- Version 2.5.4 +-- +-- * made the merging combinators more general introducing @pAtMost@, @pBetween@ and @pAtLeast@; examples are extended; see @`demo_merge`@ +-- +-- * used CPP in order to generate demo's easily +-- +-- * fixed a bug which made @pPos@ ambiguous +-- +-- * modified haddock stuff +-- -- Version 2.5.3 -- -- * fixed a bug in the implementation; some functions were too strict, due to introduction of nice abstractions!! -- -- * added a generalisation of @`pMerged`@ and @`pPerms`@ to the module "Text.ParserCombinators.UU.Derived"; the old modules have been marked as deprecated +-- -- * removed the old module Text.ParserCombinators.UU.Parsing, which was already marged as deprecated -- -- Version 2.5.2 diff --git a/src/Text/ParserCombinators/UU/Core.hs b/src/Text/ParserCombinators/UU/Core.hs --- a/src/Text/ParserCombinators/UU/Core.hs +++ b/src/Text/ParserCombinators/UU/Core.hs @@ -38,8 +38,8 @@ -- | The input state may contain a location which can be used in error messages. Since we do not want to fix our input to be just a @String@ we provide an interface -- which can be used to advance the location by passing its information in the function splitState -class loc `IsLocationUpdatedBy` a where - advance::loc -> a -> loc +class Show loc => loc `IsLocationUpdatedBy` str where + advance::loc -> str -> loc -- ** An extension to @`Alternative`@ which indicates a biased choice -- | In order to be able to describe greedy parsers we introduce an extra operator, whch indicates a biased choice @@ -68,7 +68,7 @@ instance Applicative (T state) where T ph pf pr <*> ~(T qh qf qr) = T ( \ k -> ph (\ pr -> qh (\ qr -> k (pr qr)))) ((apply .) . (pf .qf)) - ( pr . qr) + ( pr . qr) T ph pf pr <* ~(T _ _ qr) = T ( ph. (qr.)) (pf. qr) (pr . qr) T _ _ pr *> ~(T qh qf qr ) = T ( pr . qh ) (pr. qf) (pr . qr) pure a = T ($a) ((push a).) id @@ -79,18 +79,11 @@ (\ k inp -> pr k inp `best` qr k inp) empty = T ( \ k inp -> noAlts) ( \ k inp -> noAlts) ( \ k inp -> noAlts) +{- -- instance ExtAlternative (T st) where -- unfortunatelythis is not possible since we have to make the choice for swapping elsewhere +-} -choose:: (forall a . Steps a -> Steps a -> Steps a) -> T st a -> T st a -> T st a -choose best (T ph pf pr) (T qh qf qr) = - T (\ k st -> let left = norm (ph k st) - in if has_success left then left else left `best` qh k st) - (\ k st -> let left = norm (pf k st) - in if has_success left then left else left `best` qf k st) - (\ k st -> let left = norm (pr k st) - in if has_success left then left else left `best` qr k st) - instance ExtAlternative Maybe where Nothing <<|> r = r @@ -99,32 +92,35 @@ -- * The descriptor @`P`@ of a parser, including the tupled parser corresponding to this descriptor --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% --- %%%%%%%%%%%%% Parser Descriptors %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-- +data P st a = P (T st a) -- actual parsers + (Maybe (T st a)) -- non-empty parsers; Nothing if they are absent + Nat -- minimal length + (Maybe a) -- possibly empty with value -data P st a = P (T st a) -- actual parsers - (Maybe (T st a)) -- non-empty parsers; Nothing if they are absent - Nat -- minimal length - (Maybe a) -- possibly empty with value +instance Show (P st a) where + show (P _ nt n e) = "P _ " ++ maybe "Nothing" (const "(Just _)") nt ++ " (" ++ show n ++ ") " ++ maybe "Nothing" (const "(Just _)") e getOneP (P _ (Just _) Zero _ ) = error "The element is a special parser which cannot be combined" getOneP (P _ Nothing l _ ) = Nothing getOneP (P _ onep l ep ) = Just( P (mkParser onep Nothing) onep l Nothing) getZeroP (P _ _ l Nothing) = Nothing -getZeroP (P _ _ l pe) = Just (P (mkParser Nothing pe) Nothing l pe) -- TODO check for erroneaoius parsers, such as +getZeroP (P _ _ l pe) = Just (P (mkParser Nothing pe) Nothing l pe) -- TODO check for erroneous parsers mkParser np@Nothing ne@Nothing = empty mkParser np@(Just nt) ne@Nothing = nt -mkParser np@Nothing ne@(Just a) = (pure a) +mkParser np@Nothing ne@(Just a) = (pure a) mkParser np@(Just nt) ne@(Just a) = (nt <|> pure a) -combine Nothing Nothing _ _ _ _ = Nothing -combine (Just p) Nothing aq _ op1 op2 = Just (p `op1` aq ) -combine (Just p) (Just v) aq (Just _) op1 op2 = Just (p `op1` aq <|> v `op2` aq) -combine (Just p) (Just v) aq Nothing op1 op2 = Just (p `op1` aq ) -- rhs contribution is just from empty alt -combine Nothing (Just v) aq (Just _) _ op2 = Just ( v `op2` aq) -combine Nothing (Just v) aq Nothing _ op2 = Nothing -- rhs contribution is just from empty alt +-- combine creates the non-empty parser +combine Nothing Nothing _ _ _ _ = Nothing -- this Parser always fails +combine (Just p) Nothing aq _ op1 op2 = Just (p `op1` aq) +combine (Just p) (Just v) aq nq op1 op2 = case nq of + Just nnq -> Just (p `op1` aq <|> v `op2` nnq) + Nothing -> Just (p `op1` aq ) -- rhs contribution is just from empty alt +combine Nothing (Just v) _ nq _ op2 = case nq of + Just nnq -> Just (v `op2` nnq) -- right hand side has non-empty part + Nothing -> Nothing -- neither side has non-empty part -- ** Parsers are functors: @`fmap`@ instance Functor (P state) where @@ -139,16 +135,16 @@ -- ** Parsers are Applicative: @`<*>`@, @`<*`@, @`*>`@ and @`pure`@ instance Applicative (P state) where P ap np pl pe <*> ~(P aq nq ql qe) = let newnp = combine np pe aq nq (<*>) (<$>) - newep = pe <*> qe newlp = nat_add pl ql + newep = pe <*> qe in P (mkParser newnp newep) newnp newlp newep P ap np pl pe <* ~(P aq nq ql qe) = let newnp = combine np pe aq nq (<*) (<$) - newep = pe <* qe newlp = nat_add pl ql + newep = pe <* qe in P (mkParser newnp newep) newnp newlp newep P ap np pl pe *> ~(P aq nq ql qe) = let newnp = combine np pe aq nq (*>) (flip const) - newep = qe newlp = nat_add pl ql + newep = pe *> qe in P (mkParser newnp newep) newnp newlp newep pure a = P (pure a) Nothing Zero (Just a) @@ -157,15 +153,12 @@ -- ** Parsers are Alternative: @`<|>`@ and @`empty`@ instance Alternative (P state) where P ap np pl pe <|> P aq nq ql qe - = let (rl, b) = nat_min pl ql 0 + = let (rl, b) = trace' "calling natMin from <|>" (nat_min pl ql 0) Nothing `alt` q = q p `alt` Nothing = p Just p `alt` Just q = Just (p <|>q) in let nnp = (if b then (nq `alt` np) else (np `alt` nq)) - nep = (case (pe, qe) of - (Nothing, _ ) -> qe - (_ , Nothing) -> pe - (_ , _ ) -> error "ambiguous parser because two sides of choice can be empty") + nep = if b then trace' "calling pe" pe else trace' "calling qe" qe in P (mkParser nnp nep) nnp rl nep empty = P empty empty Infinite Nothing @@ -177,10 +170,18 @@ P ap np pl pe <<|> P aq nq ql qe = let (rl, b) = nat_min pl ql 0 bestx = if b then flip best else best - in P (choose bestx ap aq ) - (maybe np (\nqq -> maybe nq (\npp -> return( choose bestx npp nqq)) np) nq) + choose:: T st a -> T st a -> T st a + choose (T ph pf pr) (T qh qf qr) + = T (\ k st -> let left = norm (ph k st) + in if has_success left then left else left `bestx` qh k st) + (\ k st -> let left = norm (pf k st) + in if has_success left then left else left `bestx` qf k st) + (\ k st -> let left = norm (pr k st) + in if has_success left then left else left `bestx` qr k st) + in P (choose ap aq ) + (maybe np (\nqq -> maybe nq (\npp -> return( choose npp nqq)) np) nq) rl - (pe <|> qe) + (pe <|> qe) -- due to the way Maybe is instance of Alternative the left hand operator gets priority -- ** Parsers can recognise single tokens: @`pSym`@ and @`pSymExt`@ -- Many parsing libraries do not make a distinction between the terminal symbols of the language recognised @@ -188,13 +189,15 @@ -- This happens e.g. if we want to recognise an integer or an identifier: -- we are also interested in which integer occurred in the input, or which identifier. -- The function `pSymExt` takes as argument a value of some type `symbol', and returns a value of type `token'. --- The parser will in general depend on some --- state which is maintained holding the input. The functional dependency fixes the `token` type, based on the `symbol` type and the type of the parser `p`. +-- +-- The parser will in general depend on some +-- state which holds the input. The functional dependency fixes the `token` type, +-- based on the `symbol` type and the type of the parser `p`. --- | Since `pSymExt' is overloaded both the type and the value of symbol determine how to decompose the input in a `token` --- and the remaining input. --- `pSymExt` takes two extra parameters: one describing the minimal number of tokens recognised, --- and the second whether the symbol can recognise the empty string and the value which is to be returned in that case +-- | Since `pSymExt' is overloaded both the type and the value of a symbol +-- determine how to decompose the input in a `token` and the remaining input. +-- `pSymExt` takes two extra parameters: the first describing the minimal number of tokens recognised, +-- and the second telling whether the symbol can recognise the empty string and the value which is to be returned in that case pSymExt :: (Provides state symbol token) => Nat -> Maybe token -> symbol -> P state token pSymExt l e a = P t (Just t) l e @@ -207,6 +210,7 @@ pSym :: (Provides state symbol token) => symbol -> P state token pSym s = pSymExt (Succ Zero) Nothing s + -- ** Parsers are Monads: @`>>=`@ and @`return`@ -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% Monads %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -216,14 +220,14 @@ unParser_f (P (T _ f _ ) _ _ _ ) = f unParser_r (P (T _ _ r ) _ _ _ ) = r --- pas op de P moet aan de buitenkant !! +-- !! do not move the P constructor behind choices/patern matches instance Monad (P st) where p@(P ap np lp ep) >>= a2q = (P newap newnp (nat_add lp (error "cannot compute minimal length of right hand side of monadic parser")) newep) where (newep, newnp, newap) = case ep of Nothing -> (Nothing, t, maybe empty id t) Just a -> let P aq nq lq eq = a2q a - in ( eq, combine t nq , t `alt` aq) + in (eq, combine t nq , t `alt` aq) Nothing `alt` q = q Just p `alt` q = p <|> q t = case np of @@ -239,7 +243,6 @@ -- * Additional useful combinators --- ** Controlling the text of error reporting: @``@ -- | The parsers build a list of symbols which are expected at a specific point. -- This list is used to report errors. -- Quite often it is more informative to get e.g. the name of the non-terminal. @@ -257,9 +260,8 @@ in P (mkParser nnp pe) nnp pl pe - --- ** Parsers can be disambiguated using micro-steps: @`micro`@ -- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; for its use see `Text.ParserCombinators.UU.Examples` +micro :: P state a -> Int -> P state a P _ np pl pe `micro` i = let nnp = case np of Nothing -> Nothing @@ -268,8 +270,7 @@ ( \ k st -> pr (Micro i .k) st)) in P (mkParser nnp pe) nnp pl pe --- ** Dealing with (non-empty) Ambigous parsers: @`amb`@ --- For the precise functionng of the combinators we refer to the technical report mentioned in the README file +-- For the precise functioning of the combinators we refer to the technical report mentioned in the README file -- @`amb`@ converts an ambiguous parser into a parser which returns a list of possible recognitions. amb :: P st a -> P st [a] amb (P _ np pl pe) @@ -284,23 +285,23 @@ in P (mkParser nnp nep) nnp pl nep --- ** Parse errors can be retreived from the state: @`pErrors`@ -- | `getErrors` retreives the correcting steps made since the last time the function was called. The result can, --- using a monad, be used to control how to-- proceed with the parsing process. +-- using a monad, be used to control how to proceed with the parsing process. class state `Stores` error | state -> error where getErrors :: state -> ([error], state) +-- | The class @`Stores`@ is used by the function @`pErrors`@ which retreives the generated correction spets since the last time it was called. +-- pErrors :: Stores st error => P st [error] pErrors = let nnp = Just (T ( \ k inp -> let (errs, inp') = getErrors inp in k errs inp' ) ( \ k inp -> let (errs, inp') = getErrors inp in push errs (k inp')) ( \ k inp -> let (errs, inp') = getErrors inp in k inp' )) nep = (Just (error "pErrors cannot occur in lhs of bind")) -- the errors consumed cannot be determined statically! - in P (mkParser nnp nep) nnp Zero nep + in P (mkParser nnp Nothing) nnp Zero Nothing --- ** The current position can be retreived from the state: @`pPos`@ --- | `pPos` retreives the correcting steps made since the last time the function was called. The result can, +-- | @`pPos`@ retreives the correcting steps made since the last time the function was called. The result can, -- using a monad, be used to control how to-- proceed with the parsing process. class state `HasPosition` pos | state -> pos where @@ -311,11 +312,9 @@ ( \ k inp -> let pos = getPos inp in push pos (k inp)) ( \ k inp -> let pos = getPos inp in k inp )) nep = Just (error "pPos cannot occur in lhs of bind") -- the errors consumed cannot be determined statically! - in P (mkParser nnp nep) nnp Zero nep - + in P (mkParser nnp Nothing) nnp Zero Nothing --- ** Starting and finalising the parsing process: @`pEnd`@ and @`parse`@ --- | The function `pEnd` should be called at the end of the parsing process. It deletes any unsonsumed input, and reports its preence as an eror. +-- | The function `pEnd` should be called at the end of the parsing process. It deletes any unconsumed input, turning them into error messages pEnd :: (Stores st error, Eof st) => P st [error] pEnd = let nnp = Just ( T ( \ k inp -> let deleterest inp = case deleteAtEnd inp of @@ -333,19 +332,23 @@ in (k finalstate) Just (i, inp') -> Fail [] [const (i, deleterest inp')] in deleterest inp)) - nep = Nothing -- (error "Unforeseen use of pEnd function; pEnd should only be used in function running the actual parser") - in P (mkParser nnp nep) nnp Zero nep + in P (mkParser nnp Nothing) nnp Zero Nothing -- The function @`parse`@ shows the prototypical way of running a parser on a some specific input --- By default we use the future parser, since this gives us access to partal result; future parsers are expected to run in less space +-- By default we use the future parser, since this gives us access to partal result; future parsers are expected to run in less space. + parse :: (Eof t) => P t a -> t -> a -parse (P (T _ pf _) _ _ _) = fst . eval . pf (\ rest -> if eof rest then succeedAlways else error "pEnd missing?") -parse_h (P (T ph _ _) _ _ _) = fst . eval . ph (\ a rest -> if eof rest then push a failAlways else error "pEnd missing?") +parse (P (T _ pf _) _ _ _) = fst . eval . pf (\ rest -> if eof rest then Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?")))) + else error "pEnd missing?") +parse_h (P (T ph _ _) _ _ _) = fst . eval . ph (\ a rest -> if eof rest then push a (Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))) + else error "pEnd missing?") --- ** The state may be temporarily change type: @`pSwitch`@ --- | `pSwitch` takes the current state and modifies it to a different type of state to which its argument parser is applied. +-- | @`pSwitch`@ takes the current state and modifies it to a different type of state to which its argument parser is applied. -- The second component of the result is a function which converts the remaining state of this parser back into a valuee of the original type. +-- For the second argumnet to @`pSwitch`@ (say split) we expect the following to hold: +-- +-- > let (n,f) = split st in f n to be equal to st pSwitch :: (st1 -> (st2, st2 -> st1)) -> P st2 a -> P st1 a -- we require let (n,f) = split st in f n to be equal to st pSwitch split (P _ np pl pe) @@ -393,11 +396,14 @@ noAlts = Fail [] [] has_success (Step _ _) = True -has_success _ = False +has_success _ = False --- ! @`eval`@ removes the progress information from a sequence of steps, and constructs the value contained in it. +-- ! @`eval`@ removes the progress information from a sequence of steps, and constructs the value embedded in it. +-- If you are really desparate to see how your parsers are making progress (e.g. when you have written an ambiguous parser, and you cannot find the cause of +-- the exponential blow-up of your parsing process, you may switch on the trace in the function @`eval`@ +-- eval :: Steps a -> a -eval (Step n l) = trace' ("Step " ++ show n ++ "\n") (eval l) +eval (Step n l) = {- trace ("Step " ++ show n ++ "\n")-} (eval l) eval (Micro _ l) = eval l eval (Fail ss ls ) = trace' ("expecting: " ++ show ss) (eval (getCheapest 3 (map ($ss) ls))) eval (Apply f l ) = f (eval l) @@ -411,6 +417,8 @@ pushapply :: (b -> a) -> Steps (b, r) -> Steps (a, r) pushapply f = Apply (\ (b, r) -> (f b, r)) +-- | @`norm`@ makes sure that the head of the seqeunce contains progress information. It does so by pushing information about the result (i.e. the @Apply@ steps) backwards. +-- norm :: Steps a -> Steps a norm (Apply f (Step p l )) = Step p (Apply f l) norm (Apply f (Micro c l )) = Micro c (Apply f l) @@ -422,7 +430,7 @@ applyFail f = map (\ g -> \ ex -> let (c, l) = g ex in (c, f l)) -best :: Steps a -> Steps a -> Steps a +-- | The function @best@ compares two streams and best :: Steps a -> Steps a -> Steps a x `best` y = norm x `best'` norm y best' :: Steps b -> Steps b -> Steps b @@ -520,26 +528,25 @@ -- ** The type @`Nat`@ for describing the minimal number of tokens consumed -- | The data type @`Nat`@ is used to represent the minimal length of a parser. --- Care should be taken in order to not evaluate the right hand side of the binary functions @`nat_min`@ and @`nat-add`@ more than necesssary. +-- Care should be taken in order to not evaluate the right hand side of the binary function @`nat-add`@ more than necesssary. data Nat = Zero | Succ Nat | Infinite deriving Show +nat_min _ Zero _ = trace' "Right Zero in nat_min\n" (Zero, False) nat_min Zero _ _ = trace' "Left Zero in nat_min\n" (Zero, True) nat_min Infinite r _ = trace' "Left Infinite in nat_min\n" (r, False) -nat_min l Infinite _ = trace' "Right Zero in nat_min\n" (l, True) -nat_min _ Zero _ = trace' "Right Zero in nat_min\n" (Zero, False) -nat_min (Succ ll) (Succ rr) n = if n >1000 then error "problem with comparing lengths" - else trace' "Succs in nat_min\n" (let (v, b) = nat_min ll rr (n+1) in (Succ v, b)) +nat_min l Infinite _ = trace' "Right Infinite in nat_min\n" (l, True) +nat_min (Succ ll) (Succ rr) n = if n > 1000 then error "problem with comparing lengths" + else trace' ("Succ in nat_min " ++ show n ++ "\n") (let (v, b) = nat_min ll rr (n+1) in (Succ v, b)) nat_add Infinite _ = trace' "Infinite in add\n" Infinite nat_add Zero r = trace' "Zero in add\n" r nat_add (Succ l) r = trace' "Succ in add\n" (Succ (nat_add l r)) --- get_length (P _ _ l _) = l - +get_length (P _ _ l _) = l trace' m v = {- trace m -} v diff --git a/src/Text/ParserCombinators/UU/Derived.hs b/src/Text/ParserCombinators/UU/Derived.hs --- a/src/Text/ParserCombinators/UU/Derived.hs +++ b/src/Text/ParserCombinators/UU/Derived.hs @@ -11,10 +11,20 @@ import Text.ParserCombinators.UU.Core import Control.Monad --- | This module contains a large variety of combinators for list-lile structures. the extension @_ng@ indiactes that that varinat is the non-greedy variant. +-- | This module contains a large variety of combinators for list-lile structures. the extension @_ng@ indiactes that +-- that variant is the non-greedy variant. -- See the "Text.ParserCombinators.UU.Examples" module for some exmaples of their use. +-- * Some common combinators for oft occurring constructs + +-- | @`pReturn`@ is defined for upwards comptaibility +-- +pReturn :: a -> P str a pReturn = pure + +-- | @`pFail`@ is defined for upwards comptaibility, and is the unit for @<|>@ +-- +pFail :: P str a pFail = empty infixl 4 @@ -30,54 +40,60 @@ opt :: P st a -> a -> P st a p `opt` v = must_be_non_empty "opt" p (p <<|> pure v) +-- | @pMaybe@ greedily recognises its argument. If not @Nothing@ is returned. +-- pMaybe :: P st a -> P st (Maybe a) pMaybe p = must_be_non_empty "pMaybe" p (Just <$> p `opt` Nothing) +-- | @pEither@ recognises either one of its arguments. +-- +pEither :: P str a -> P str b -> P str (Either a b) pEither p q = Left <$> p <|> Right <$> q +-- | @<$$>@ is the version of @<$>@ which maps on its second argument +-- (<$$>) :: (a -> b -> c) -> P st b -> P st (a -> c) f <$$> p = flip f <$> p +-- | @@ parses an optional postfix element and applies its result to its left hand result +-- () :: P st a -> P st (a -> a) -> P st a -p q = p <**> (q `opt` id) +p q = must_be_non_empty "" q (p <**> (q `opt` id)) --- | This can be used to parse 'x' surrounded by 'l' and 'r'. --- --- Example: --- --- > pParens = pPacked pOParen pCParen +-- | @`pPackes`@ surrounds its third parser with the first and the seond one, keeping only the middle result pPacked :: P st b1 -> P st b2 -> P st a -> P st a pPacked l r x = l *> x <* r --- ======================================================================================= --- ===== Iterating ps ==================================================================== --- ======================================================================================= +-- * The collection of iterating combinators, all in a greedy (default) and a non-greedy variant + pFoldr :: (a -> a1 -> a1, a1) -> P st a -> P st a1 -pFoldr_ng :: (a -> a1 -> a1, a1) -> P st a -> P st a1 pFoldr alg@(op,e) p = must_be_non_empty "pFoldr" p pfm where pfm = (op <$> p <*> pfm) `opt` e + +pFoldr_ng :: (a -> a1 -> a1, a1) -> P st a -> P st a1 pFoldr_ng alg@(op,e) p = must_be_non_empty "pFoldr_ng" p pfm where pfm = (op <$> p <*> pfm) <|> pure e pFoldr1 :: (v -> b -> b, b) -> P st v -> P st b -pFoldr1_ng :: (v -> b -> b, b) -> P st v -> P st b pFoldr1 alg@(op,e) p = must_be_non_empty "pFoldr1" p (op <$> p <*> pFoldr alg p) + +pFoldr1_ng :: (v -> b -> b, b) -> P st v -> P st b pFoldr1_ng alg@(op,e) p = must_be_non_empty "pFoldr1_ng" p (op <$> p <*> pFoldr_ng alg p) pFoldrSep :: (v -> b -> b, b) -> P st a -> P st v -> P st b -pFoldrSep_ng :: (v -> b -> b, b) -> P st a -> P st v -> P st b pFoldrSep alg@(op,e) sep p = must_be_non_empties "pFoldrSep" sep p (op <$> p <*> pFoldr alg sepp `opt` e) where sepp = sep *> p +pFoldrSep_ng :: (v -> b -> b, b) -> P st a -> P st v -> P st b pFoldrSep_ng alg@(op,e) sep p = must_be_non_empties "pFoldrSep" sep p (op <$> p <*> pFoldr_ng alg sepp <|> pure e) where sepp = sep *> p pFoldr1Sep :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b -pFoldr1Sep_ng :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b pFoldr1Sep alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep" sep p pfm where pfm = op <$> p <*> pFoldr alg (sep *> p) +pFoldr1Sep_ng :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b pFoldr1Sep_ng alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep_ng" sep p pfm where pfm = op <$> p <*> pFoldr_ng alg (sep *> p) @@ -85,36 +101,36 @@ list_alg = ((:), []) pList :: P st a -> P st [a] -pList_ng :: P st a -> P st [a] pList p = must_be_non_empty "pList" p (pFoldr list_alg p) +pList_ng :: P st a -> P st [a] pList_ng p = must_be_non_empty "pList_ng" p (pFoldr_ng list_alg p) pList1 :: P st a -> P st [a] -pList1_ng :: P st a -> P st [a] pList1 p = must_be_non_empty "pList" p (pFoldr1 list_alg p) +pList1_ng :: P st a -> P st [a] pList1_ng p = must_be_non_empty "pList_ng" p (pFoldr1_ng list_alg p) pListSep :: P st a1 -> P st a -> P st [a] -pListSep_ng :: P st a1 -> P st a -> P st [a] pListSep sep p = must_be_non_empties "pListSep" sep p (pFoldrSep list_alg sep p) +pListSep_ng :: P st a1 -> P st a -> P st [a] pListSep_ng sep p = must_be_non_empties "pListSep_ng" sep p pFoldrSep_ng list_alg sep p pList1Sep :: P st a1 -> P st a -> P st [a] -pList1Sep_ng :: P st a1 -> P st a -> P st [a] pList1Sep s p = must_be_non_empties "pListSep" s p (pFoldr1Sep list_alg s p) +pList1Sep_ng :: P st a1 -> P st a -> P st [a] pList1Sep_ng s p = must_be_non_empties "pListSep_ng" s p (pFoldr1Sep_ng list_alg s p) pChainr :: P st (c -> c -> c) -> P st c -> P st c -pChainr_ng :: P st (c -> c -> c) -> P st c -> P st c pChainr op x = must_be_non_empties "pChainr" op x r where r = x (flip <$> op <*> r) +pChainr_ng :: P st (c -> c -> c) -> P st c -> P st c pChainr_ng op x = must_be_non_empties "pChainr_ng" op x r where r = x <**> ((flip <$> op <*> r) <|> pure id) pChainl :: P st (c -> c -> c) -> P st c -> P st c -pChainl_ng :: P st (c -> c -> c) -> P st c -> P st c pChainl op x = must_be_non_empties "pChainl" op x (f <$> x <*> pList (flip <$> op <*> x)) where f x [] = x f x (func:rest) = f (func x) rest +pChainl_ng :: P st (c -> c -> c) -> P st c -> P st c pChainl_ng op x = must_be_non_empties "pChainl_ng" op x (f <$> x <*> pList_ng (flip <$> op <*> x)) where f x [] = x f x (func:rest) = f (func x) rest @@ -131,34 +147,50 @@ mzero = pFail mplus = (<|>) --- ======================================================================================= --- ===== Merging parsers: see at end of Examples file ==================================== --- ======================================================================================= +-- * Merging parsers infixl 3 <||> -data Freq p = One p - | Opt p - | Many p - | Some p +data Freq p = AtLeast Int p + | AtMost Int p + | Between Int Int p + | One p + | Many p + | Opt p + | Never p + instance Functor Freq where - fmap f (One p) = One (f p) - fmap f (Opt p) = Opt (f p) - fmap f (Many p) = Many (f p) - fmap f (Some p) = Some (f p) + fmap f (AtLeast n p) = AtLeast n (f p) + fmap f (AtMost n p) = AtMost n (f p) + fmap f (Between n m p) = Between n m (f p) + fmap f (One p) = One (f p) + fmap f (Many p) = Many (f p) + fmap f (Opt p) = Opt (f p) + fmap f (Never p) = Never (f p) -canBeEmpty (One p) = False -canBeEmpty (Opt p) = True -canBeEmpty (Many p) = True -canBeEmpty (Some p) = False +canBeEmpty (AtLeast _ p) = False +canBeEmpty (AtMost _ p) = True +canBeEmpty (Between n m p) = if n==0 then error "wrong use of Between" else False -- safety check +canBeEmpty (One p) = False +canBeEmpty (Many p) = True +canBeEmpty (Opt p) = True +canBeEmpty (Never p) = True -oneAlt (One p, others) = (p, toTree others) -oneAlt (Opt p, others) = (p, toTree others) -oneAlt (Many p, others) = (p, toTree (Many p:others)) -oneAlt (Some p, others) = (p, toTree (Many p:others)) +oneAlt (AtLeast 1 p, others) = (p, toTree (Many p : others)) +oneAlt (AtLeast n p, others) = (p, toTree (AtLeast (n-1) p : others)) +oneAlt (AtMost 1 p, others) = (p, toTree others ) +oneAlt (AtMost n p, others) = (p, toTree (AtMost (n-1) p : others)) +oneAlt (Between 1 1 p, others) = (p, toTree others ) +oneAlt (Between 1 m p, others) = (p, toTree (AtMost (m-1) p : others)) +oneAlt (Between n m p, others) = (p, toTree (Between (n-1) (m-1) p : others)) +oneAlt (One p, others) = (p, toTree others ) +oneAlt (Many p, others) = (p, toTree (Many p : others)) +oneAlt (Opt p, others) = (p, toTree others ) data Tree p = Br [(p, Tree p)] Bool +-- this code can be optimised in order to avoid repeated analyses; to be done later +-- toTree :: [Freq p] -> Tree p toTree alts = Br (map oneAlt (split alts id)) (and (map canBeEmpty alts) ) split [] _ = [] @@ -184,10 +216,20 @@ pMerge :: c -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e sem `pMerge` MergeSpec (units, alts, unp) = unp sem <$> toParser (toTree alts) units -pMany p = must_be_non_empty "pMany" p (MergeSpec ([] ,[Many ((:) <$> p)], id)) -pOpt p v = must_be_non_empty "pOpt" p (MergeSpec (v ,[Opt (const <$> p)], id)) -pSome p = must_be_non_empty "pSome" p (MergeSpec ([] ,[Some ((:) <$> p)], id)) -pOne p = must_be_non_empty "pOne" p (MergeSpec (undefined,[One (const <$> p)], id)) +pBetween n m p = must_be_non_empty "pOpt" p + (if m p)], id)) + else (MergeSpec ([] ,[Between n m ((:) <$> p)], id))) +pAtMost n p = must_be_non_empty "pOpt" p + (if n <= 0 then (MergeSpec ([] ,[ ], id)) + else (MergeSpec ([] ,[AtMost n ((:) <$> p)], id))) +pAtLeast n p = must_be_non_empty "pOpt" p + (if n <= 0 then (MergeSpec ([] ,[Many ((:) <$> p)], id)) + else (MergeSpec ([] ,[AtLeast n ((:) <$> p)], id))) +pMany p = must_be_non_empty "pMany" p (MergeSpec ([] ,[Many ((:) <$> p)], id)) +pOpt p v = must_be_non_empty "pOpt" p (MergeSpec (v ,[Opt (const <$> p)], id)) +pSome p = must_be_non_empty "pSome" p (MergeSpec ([] ,[AtLeast 1 ((:) <$> p)], id)) +pOne p = must_be_non_empty "pOne" p (MergeSpec (undefined,[One (const <$> p)], id)) mapFst f (a, b) = (f a, b) mapSnd f (a, b) = (a, f b) diff --git a/src/Text/ParserCombinators/UU/Examples.hs b/src/Text/ParserCombinators/UU/Examples.hs --- a/src/Text/ParserCombinators/UU/Examples.hs +++ b/src/Text/ParserCombinators/UU/Examples.hs @@ -1,14 +1,15 @@ {-# OPTIONS_HADDOCK ignore-exports #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, - MultiParamTypeClasses #-} + MultiParamTypeClasses, + CPP #-} -- | This module contains a lot of examples of the typical use of our parser combinator library. -- We strongly encourage you to take a look at the source code --- At the end you find a @`main`@ function which demonsrates the main characteristics. --- Only the `@run`@ function is exported since it may come in handy elsewhere. +-- At the end you find a @`main`@ function which demonstrates the main characteristics. +-- Only the @`run`@ function is exported since it may come in handy elsewhere. -module Text.ParserCombinators.UU.Examples (run) where +module Text.ParserCombinators.UU.Examples (run, demo) where import Char import Text.ParserCombinators.UU.Core import Text.ParserCombinators.UU.BasicInstances @@ -261,21 +262,7 @@ test13 = run takes_second_alt "if a then if else c" test14 = run takes_second_alt "ifx a then if else c" -{- --- | For documentation of @`pMerge`@ and @`<||>`@ see the module "Text.ParserCombinators.UU.Merge": --- --- > run (,,) `pMerged` (list_of pDigit <||> list_of pLower <||> list_of pUpper) "1AabCD2D3d" --- --- results in --- --- > Result: ("123","abd","ACDD") --- - -test15 :: IO () -test15 = run ((,,) `pMerged` (list_of pDigit <||> list_of pLower <||> list_of pUpper)) "1AabCD2D3d" --} - -- | The function -- -- > munch = pMunch ( `elem` "^=*") @@ -342,38 +329,50 @@ -- parsing two alternatives and returning both rsults pIntList :: Parser [Int] pIntList = pParens ((pSym ';') `pListSep` (read <$> pList1 (pSym ('0', '9')))) +parseIntString :: Parser [String] parseIntString = pParens ((pSym ';') `pListSep` ( pList1 (pSym ('0', '9')))) -parseBoth = amb (Left <$> parseIntString <|> Right <$> pIntList) +#define DEMO(p,i) demo "p" i p +justamessage = "justamessage" + main :: IO () -main = do test1 - run pa "b" - run pa2 "bbab" - run pa "ba" - run pa "aa" - run (do {l <- pCount pa; pExact l pb}) "aaacabbbb" - run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaabaa" - run paz "ab1z7" - run paz' "m" - run paz' "" - run (pa <|> pb {- "just a message"-}) "c" - run parseBoth "(123;456;789)" - run munch "a^=^**^^b" - run ((,,,) `pMerge` (pSome pa <||> pMany pb <||> pOne pc <||> pOpt pNatural 5)) "babc45" +main = do DEMO (pa, "a") + DEMO (pa, "b") + DEMO (((++) <$> pa <*> pa), "bbab") + DEMO (pa, "ba") + DEMO (pa, "aa") + DEMO ((do {l <- pCount pa; pExact l pb}), "aaacabbbb") + DEMO ((amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)), "aaaaa") + DEMO (paz, "ab1z7") + DEMO ((pa <|> pb justamessage), "c") + DEMO ((amb (pEither parseIntString pIntList)), "(123;456;789)") + DEMO (munch, "a^=^**^^b") + demo_merge -demo_merge :: IO () -demo_merge = do run ((,) `pMerge` (pSome pa <||> pMany pb)) "abba" - run ((,) `pMerge` (pSome pa <||> pMany pb)) "a" - run ((,) `pMerge` (pSome pa <||> pMany pb)) "" - run ((,) `pMerge` (pMany pb <||> pSome pc)) "bcbc" - run ((,) `pMerge` (pSome pb <||> pMany pc)) "bcbc" - run ((,,,) `pMerge` (pSome pa <||> pMany pb <||> pOne pc <||> pNatural `pOpt` 5)) "babc45" --- Text.ParserCombinators.UU.Examples> run (id `pMerge` (pSome (pa `opt` "b"))) "a" + +-- | For documentation of @`pMerge`@ and @`<||>`@ see the module "Text.ParserCombinators.UU.Merge". Here we just give a @deno_merge@, which +-- should speak for itself. Make sure your parsers are not getting ambiguous. This soon gets very expensive. -- --- > Result: *** Exception: The combinator pSome requires that it's argument cannot recognise the empty string +demo_merge :: IO () +demo_merge = do DEMO (((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pb)) , "abba") + DEMO (((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pb)) , "bba") + -- run ((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pa)) , "aaa") -- is ambiguous, and thus incorrect + DEMO ((amb ((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pa))) , "aaa") + putStr "The 'a' at the right hand side can b any of the three 'a'-s in the input\n" + DEMO (((,) `pMerge` (pAtLeast 3 pa <||> pAtMost 3 pb)) , "aabbbb") + DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "abba") + DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "abba") + DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "") + DEMO (((,) `pMerge` (pMany pb <||> pSome pc)) , "bcbc") + DEMO (((,) `pMerge` (pSome pb <||> pMany pc)) , "bcbc") + DEMO (((,,,) `pMerge` (pSome pa <||> pMany pb <||> pOne pc <||> pNatural `pOpt` 5)), "babc45" ) + DEMO (((,) `pMerge` (pMany (pa <|> pb) <||> pSome pNatural)) , "1ab12aab14") +demo :: Show r => String -> String -> Parser r -> IO () +demo str input p= do putStr ("\n===========================================\n>> run " ++ str ++ " " ++ show input ++ "\n") + run p input diff --git a/uu-parsinglib.cabal b/uu-parsinglib.cabal --- a/uu-parsinglib.cabal +++ b/uu-parsinglib.cabal @@ -1,5 +1,5 @@ Name: uu-parsinglib -Version: 2.5.3 +Version: 2.5.4 Build-Type: Simple License: MIT Copyright: S Doaitse Swierstra