uu-parsinglib 2.5.3 → 2.5.4

raw patch · 6 files changed

+239/−174 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Text/ParserCombinators/UU/BasicInstances.hs +16/−10
• src/Text/ParserCombinators/UU/CHANGELOG.hs +11/−0
• src/Text/ParserCombinators/UU/Core.hs +85/−78
• src/Text/ParserCombinators/UU/Derived.hs +85/−43
• src/Text/ParserCombinators/UU/Examples.hs +41/−42
• uu-parsinglib.cabal +1/−1

@@ -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

@@ -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

@@ -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  

@@ -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 <n || m <= 0 then         (MergeSpec ([]       ,[                           ], id)) +                  else if n==0 then              (MergeSpec ([]       ,[AtMost  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)

@@ -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  

@@ -1,5 +1,5 @@ Name:                uu-parsinglib-Version:             2.5.3+Version:             2.5.4 Build-Type:          Simple License:             MIT Copyright:           S Doaitse Swierstra