uu-parsinglib 2.3.4 → 2.4.0

raw patch · 9 files changed

+709/−351 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +24/−0
• README +19/−0
• src/Text/ParserCombinators/UU.hs +6/−0
• src/Text/ParserCombinators/UU/BasicInstances.hs +42/−17
• src/Text/ParserCombinators/UU/Core.hs +320/−189
• src/Text/ParserCombinators/UU/Derived.hs +32/−31
• src/Text/ParserCombinators/UU/Examples.hs +244/−63
• src/Text/ParserCombinators/UU/Parsing.hs +4/−3
• uu-parsinglib.cabal +18/−48

@@ -0,0 +1,24 @@+Versions above 2.1: +      * based on Control.Applicative+Versions above 2.2:+      *  make use of type families   +      *  contain a module with many list-based derived combinators+Version 2.3.1+      * fix for GHC 6.12, because of change in GADT definition handling+Version 2.3.2+      * added microsteps, which can be used to disambiguate+Version 2.3.3+      * added pMunch which takes a Boolean function, and recognises the longest prefix for which the symbols match the predicate +      * added the infix operator with piority 2 <?> :: P state a -> String -> P st a which replaces the list of expected symbols+        in error message by its right argument String+Version 2.3.4+      * removed dependecies on impredictaive types, preparing for next GHC version+Version 2.4.0+      * contains abstract interpretation for minimal lenth, in order to avoid recursive correction process+      * idem for checking that no repeating combinators like pList are parameterised with possibly empty parsers+++Note that the basic parser interface will probably not change much when we add more features, but the calling conventions+of the outer parser and the class structure upon which the parametrisation is based may change+                     . +                     

@@ -0,0 +1,19 @@++--- Short Description++This repository contains a completely new version of the Utrecht parser combinator library.+This library is under construction.++--- Background material++The library is based on ideas described in the paper:++@inproceedings{uuparsing:piriapolis,
Author = {Swierstra, S.~Doaitse},
Booktitle = {Language Engineering and Rigorous Software Development},
Editor = {Bove, A. and Barbosa, L. and Pardo, A. and and Sousa Pinto, J.},
Pages = {252-300},
Place = {Piriapolis},
Publisher = {Spinger},
Series = {LNCS},
Title = {Combinator Parsers: a short tutorial},
Volume = {5520},
Year = {2009}}

which is also available as a technical report from http://www.cs.uu.nl/research/techreps/repo/CS-2008/2008-044.pdf
++The first part of this report is a general introduction into parser combinators, whereas the second part contains the +motivation for and documentation of the current package.++We appreciate if you include a reference to the above documentation in any publication describing software in which you have used the library succesfully.++Any feedback on particular use of the library, and suggestions for extensions, are welcome at mailto:doaitse@swierstra.net+

@@ -0,0 +1,6 @@+module Text.ParserCombinators.UU ( module Text.ParserCombinators.UU.Core+                                 , module Text.ParserCombinators.UU.BasicInstances+                                 , module Text.ParserCombinators.UU.Derived) where+import Text.ParserCombinators.UU.Core+import Text.ParserCombinators.UU.BasicInstances+import Text.ParserCombinators.UU.Derived

@@ -13,23 +13,26 @@  module Text.ParserCombinators.UU.BasicInstances where import Text.ParserCombinators.UU.Core+import Data.List -data Error t s pos = Inserted s pos Strings-                   | Deleted  t pos Strings-                   | DeletedAtEnd t+data Error  pos =    Inserted String pos Strings+                   | Deleted  String pos Strings+                   | DeletedAtEnd String -instance (Show t, Show s, Show pos) => Show (Error t s pos) where - show (Inserted s pos expecting) = "\nInserted " ++ show s ++ " at position " ++ show pos ++  show_expecting  expecting - show (Deleted  t pos expecting) = "\nDeleted  " ++ show t ++ " at position " ++ show pos ++  show_expecting  expecting - show (DeletedAtEnd t)           = "\nThe token " ++ show t ++ "was not consumed by the parsing process." +instance (Show pos) => Show (Error  pos) where + show (Inserted s pos expecting) = "--     Inserted " ++  s ++ " at position " ++ show pos ++  show_expecting  expecting + show (Deleted  t pos expecting) = "--     Deleted  " ++  t ++ " at position " ++ show pos ++  show_expecting  expecting + show (DeletedAtEnd t)           = "--     The token " ++ t ++ " was not consumed by the parsing process." +show_errors = sequence_ . (map (putStrLn . show)) + show_expecting [a]    = " expecting " ++ a show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]" show_expecting []     = " expecting nothing"  data Str     t    = Str   {  input    :: [t]-                          ,  msgs     :: [Error t t Int ]+                          ,  msgs     :: [Error Int ]                           ,  pos      :: !Int                           ,  deleteOk :: !Bool} @@ -37,10 +40,10 @@  instance (Show a) => Provides  (Str  a)  (a -> Bool, String, a)  a where        splitState (p, msg, a) k (Str  tts   msgs pos  del_ok) -          = let ins exp =       (5, k a (Str tts (msgs ++ [Inserted a  pos  exp]) pos  False))+          = let ins exp =       (5, k a (Str tts (msgs ++ [Inserted (show a)  pos  exp]) pos  False))                 del exp =       (5, splitState (p,msg, a)                                      k-                                    (Str (tail tts)  (msgs ++ [Deleted  (head tts)  pos  exp]) (pos+1) True ))+                                    (Str (tail tts)  (msgs ++ [Deleted  (show(head tts))  pos  exp]) (pos+1) True ))             in case tts of                (t:ts)  ->  if p t                             then  Step 1 (k t (Str ts msgs (pos + 1) True))@@ -53,25 +56,47 @@ instance (Eq a, Show a) => Provides  (Str  a)  a  a where        splitState a  = splitState ((==a), show a, a)  -instance Eof (Str a) where+instance Show a => Eof (Str a) where        eof (Str  i        _    _    _    )                = null i-       deleteAtEnd (Str  (i:ii)   msgs pos ok    )        = Just (5, Str ii (msgs ++ [DeletedAtEnd i]) pos ok)+       deleteAtEnd (Str  (i:ii)   msgs pos ok    )        = Just (5, Str ii (msgs ++ [DeletedAtEnd (show i)]) pos ok)        deleteAtEnd _                                      = Nothing  -instance  Stores (Str a) [Error a a Int] where+instance  Stores (Str a) (Error Int) where        getErrors   (Str  inp      msgs pos ok    )        = (msgs, Str inp [] pos ok) --- tempory addition of pMunch+-- pMunch +data Munch a = Munch (a -> Bool)+ instance (Show a) => Provides (Str a) (Munch a) [a] where         splitState (Munch p) k (Str tts msgs pos del_ok)           =    let (munched, rest) = span p tts                    l               = length munched                in Step l (k munched (Str rest msgs (pos+l)  (l>0 || del_ok))) -data Munch a = Munch (a -> Bool)- pMunch :: (Text.ParserCombinators.UU.Core.Symbol p (Munch a) [a]) => (a -> Bool) -> p [a]-pMunch p = pSym (Munch p) +pMunch p = pSymExt Zero (Just []) (Munch p)++data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token++instance (Show a, Eq a) => Provides (Str a) (Token a) [a] where +  splitState tok@(Token  as cost) k (Str tts msgs pos del_ok)+   =  let l = length as+          msg = show as +      in  case stripPrefix as tts of+          Nothing  ->  let ins exp =  (cost, k as             (Str tts         (msgs ++ [Inserted msg               pos  exp])   pos    False))+                           del exp =  (5,    splitState tok k (Str (tail tts)  (msgs ++ [Deleted  (show(head tts))  pos  exp])  (pos+1) 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 (pos+l) True))++pToken     as   =   pTokenCost as 5+pTokenCost as c =   if null as then error "call to pToken with empty token"+                    else pSymExt (length as) Nothing (Token as c)+                    where length [] = Zero+                          length (_:as) = Succ (length as)+++ 

@@ -1,7 +1,3 @@--- | The module `Core` contains the basic functionality of the parser library. --- It takes care of the breadth-first search, the online generation of results, the core error--- correction administration, dealing with ambigous grammars, and the type for both kinds of parsers--- involved and the recognisers.   {-# LANGUAGE  RankNTypes,                GADTs,@@ -13,9 +9,14 @@               NoMonomorphismRestriction #-}  +-- | The module `Core` contains the basic functionality of the parser library. +--   It  uses the  breadth-first module  to realise online generation of results, the error+--   correction administration, dealing with ambigous grammars; it defines the types  of the elementary  parsers+--   and  recognisers involved.For typical use cases of the libray see the module @"Text.ParserCombinators.UU.Examples"@+ module Text.ParserCombinators.UU.Core ( module Text.ParserCombinators.UU.Core-                                              , module Control.Applicative) where-import Control.Applicative  hiding ((<*), (*>), (<$), many, some, optional)+                                      , module Control.Applicative) where+import Control.Applicative  hiding  ((<$), many, some, optional) import Char import Debug.Trace import Maybe@@ -23,38 +24,47 @@ -- * The Classes Defining the Interface -- ** `IsParser` - -- | This class collects a number of classes which together defines what a `Parser` should provide.  -- Since it is just a predicate we have prefixed the name by the phrase `Is'  class    (Applicative p, ExtApplicative p, Alternative p)    => IsParser p where instance (Applicative p, ExtApplicative p, Alternative p)    => IsParser p where -infixl  4  <*, *> infixl  4  <$ infix   2  <?>  -- ** `ExtApplicative'--- | The module "Control.Applicative" contains definitions for `<$`, `*>`  and `<*` which cannot be changed. Since we want to give--- optimised implementations of these combinators, we hide those definitions, and define a class containing their signatures.+-- | The module "Control.Applicative" contains the definition for `<$` which cannot be changed . +-- Since we want to give optimised implementations of this combinator, we hide its definition, and define a class containing its signature.  class  ExtApplicative p where-  (<*)      ::  p  a            -> p b   ->   p  a-  (*>)      ::  p  b            -> p a   ->   p  a   (<$)      ::  a               -> p b   ->   p  a  -- ** `Symbol' -- | Many parsing libraries do not make a distinction between the terminal symbols of the language recognised and the --- tokens actually constructed from the  input. 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. Note that if the alternative later fails repair will take place, instead of trying the other altrenatives at the greedy choice point.+-- tokens actually constructed from the  input. 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.  -class  Symbol p  symbol token | p symbol -> token where-  pSym  ::  symbol -> p token -- ^ The function `pSym` 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`.--- Since `pSym' is overloaded both the type and the value of symbol determine how to decompose the input in a `token` and the remaining input.+--   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`.+--   Since `pSym' is overloaded both the type and the value of symbol determine how to decompose the input in a `token` and the remaining input.+--   `pSymExt` is the actual function, which takes two extra parameters: one describing the minimal numer 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 +class  Symbol p  symbol token | p symbol -> token where+  -- | The first parameter to `pSymExt` is a `Nat` which describes the minimal numer of tokens accepted by this parser. It is used in the abstract interpretation+  --   which computes this property for each parser. It's main use is in choosinga non-recursive alternative in case a non-terminal has to be inserted.+  --   The second parameter indicates whether this parser can also skip recognising anything and just return a value of type a, hence a `Maybe a`+  +  pSymExt ::  Nat -> Maybe token -> symbol -> p token+  pSym    ::                        symbol -> p token+  pSym  s   = pSymExt (Succ Zero) Nothing s + -- ** `Provides' +-- | The function `splitStae` playes a crucial role in splitting up the state. The `symbol` parameter tells us what kind of thing, and even which value of that kind, is expected from the input.+--   The state  and  and the symbol type together determine what kind of token has to be returned. Since the function is overloaded we do not have to invent +--   all kind of different names for our elementary parsers. class  Provides state symbol token | state symbol -> token  where        splitState   ::  symbol -> (token -> state  -> Steps a) -> state -> Steps a @@ -64,47 +74,264 @@        eof          ::  state   -> Bool        deleteAtEnd  ::  state   -> Maybe (Cost, state) --- * Progress Information--- | The data type `Steps` is the core data type around which the parsers are constructed. It is a stream containing both the result of the parsing process,---   albeit often in a fragmented way, and progress information. Recognising a token should correspond to a certain amount of `Progress`, ---   which for the time being in an `Int`.+++-- * The type  describing parsers: @`P`@+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Parsers     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++-- do not change into data, or be prepared to add ~ at subtle places !!+data  P   st  a =  P  (forall r . (a  -> st -> Steps r)  -> st -> Steps       r  ) --  history parser+                      (forall r . (      st -> Steps r)  -> st -> Steps   (a, r) ) --  future parser+                      (forall r . (      st -> Steps r)  -> st -> Steps       r  ) --  recogniser+                      Nat                                                          --  minimal length+                      (Maybe a)                                                    --  possibly empty with value     ++-- ** Parsers are functors:  @`fmap`@+instance   Functor (P  state) where +  fmap f   (P   ph pf pr l me)   =  P  ( \  k -> ph ( k .f ))+                                       ( \  k ->  pushapply f . pf k) -- pure f <*> pf+                                       (pr) +                                       l+                                       (fmap f me)++-- ** Parsers are Applicative:  @`<*>`@,  @`<*`@,  @`*>`@ and  @`pure`@+instance   Applicative (P  state) where+  P ph pf pr pl pe <*> ~(P qh qf qr ql qe)  =  P  ( \  k -> ph (\ pr -> qh (\ qr -> k (pr qr))))+                                                  ((apply .) . (pf .qf))+                                                  ( pr . qr)+                                                  (nat_add pl ql)+                                                  (pe <*> qe)+  P ph pf pr pl pe <*  ~(P _  _  qr ql qe)   = P  ( ph. (qr.))  (pf. qr)   (pr . qr)+                                                  (nat_add pl ql) +                                                  (case qe of Nothing -> Nothing ; _ -> pe)+  P _  _  pr pl pe *>  ~(P qh qf qr ql qe)   = P ( pr . qh  )  (pr. qf)    (pr . qr)           +                                                 (nat_add pl ql) (case pe of Nothing -> Nothing ; _ -> qe) +  pure a                                     =  P  ($a) ((push a).) id Zero (Just a)+++-- ** Parsers are Alternative:  @`<|>`@ and  @`empty`@ +instance   Alternative (P   state) where +  P ph pf pr pl pe <|> P qh qf qr ql qe +    =  let (rl, b) = nat_min pl ql+           bestx :: Steps a -> Steps a -> Steps a+           bestx = if b then flip best else best +       in    P (\  k inp  -> ph k inp `bestx` qh k inp)+               (\  k inp  -> pf k inp `bestx` qf k inp)+               (\  k inp  -> pr k inp `bestx` qr k inp)+               rl+               (case (pe, qe)  of+                 (Nothing, _      ) -> qe+                 (_      , Nothing) -> pe+                 (_      , _      ) -> error "ambiguous parser because two sides of choice can be empty")+  empty                =  P  ( \  k inp  ->  noAlts)+                             ( \  k inp  ->  noAlts)+                             ( \  k inp  ->  noAlts)+                             Infinite+                             Nothing++-- ** Parsers can recognise single tokens:  @`pSym`@ and  @`pSymExt`@+instance  ( Provides state symbol token) => Symbol (P  state) symbol token where+  pSymExt l e a  = P ( \ k inp -> splitState a k inp)+                     ( \ k inp -> splitState a (\ t inp' -> push t (k inp')) inp)+                     ( \ k inp -> splitState a (\ _ inp' -> k inp') inp)+                     l+                     e++-- ** Parsers are Monads:  @`>>=`@ and  @`return`@++unParser_h (P  h   _  _  _ _)  =  h+unParser_f (P  _   f  _  _ _)  =  f+unParser_r (P  _   _  r  _ _)  =  r+          ++instance  Monad (P st) where+       P  ph pf pr pl pe >>=  a2q = +                P  (  \k -> ph (\ a -> unParser_h (a2q a) k))+                   (  \k -> ph (\ a -> unParser_f (a2q a) k))+                   (  \k -> ph (\ a -> unParser_r (a2q a) k))+                   (nat_add pl (error "cannot compute minimal length of right hand side of monadic parser"))+                   (case pe of+                    Nothing -> Nothing+                    Just a -> let (P _ _ _ _ a2qv) = a2q a in a2qv)+       return  = pure ++-- * 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. +--   The @`<?>`@ combinator replaces this list of symbols by it's righ-hand side argument.++(<?>) :: P state a -> String -> P state a+P  ph  pf  pr  pl pe <?> label = P ( \ k inp -> replaceExpected  ( ph k inp))+                                   ( \ k inp -> replaceExpected  ( pf k inp))+                                   ( \ k inp -> replaceExpected  ( pr k inp))+                                   pl+                                   pe+                           where replaceExpected (Fail _ c) = (Fail [label] c)+                                 replaceExpected others     = others+++-- ** An alternative for the Alternative, which is greedy:  @`<<|>`@+-- | `<<|>` is the greedy version of `<|>`. If its left hand side parser can make some progress that alternative is comitted. Can be used to make parsers faster, and even+--   get a complete Parsec equivalent behaviour, with all its (dis)advantages. use with are!++P ph pf pr pl pe <<|> P qh qf qr ql qe +    = let (rl, b) = nat_min pl ql+          bestx = if b then flip best else best+      in   P ( \ k st  -> norm (ph k st) `bestx` norm (qh k st))+             ( \ k st  -> norm (pf k st) `bestx` norm (qf k st))+             ( \ k st  -> norm (pr k st) `bestx` norm (qr k st))+             rl+             (case (pe, qe)  of+                 (Nothing, _      ) -> qe+                 (_      , Nothing) -> pe+                 (_      , _      ) -> error "ambiguous parser because two sides of choice can be empty")++-- ** 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` +P ph pf pr pl pe `micro` i = P ( \ k st -> ph (\ a st -> Micro i (k a st)) st)+                               ( \ k st -> pf (Micro i .k) st)+                               ( \ k st -> pr (Micro i .k) st)+                               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+--   @`amb`@ converts an ambiguous parser into a parser which returns a list of possible recognitions.+amb :: P st a -> P st [a]++amb (P ph pf pr pl pe) = P ( \k     ->  removeEnd_h . ph (\ a st' -> End_h ([a], \ as -> k as st') noAlts))+                           ( \k inp ->  combinevalues . removeEnd_f $ pf (\st -> End_f [k st] noAlts) inp)+                           ( \k     ->  removeEnd_h . pr (\ st' -> End_h ([undefined], \ _ -> k  st') noAlts))+                           pl+                           (fmap pure pe)+                         where  combinevalues  :: Steps [(a,r)] -> Steps ([a],r)+                                combinevalues lar           =   Apply (\ lar -> (map fst lar, snd (head lar))) lar++       +-- ** 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.++class state `Stores`  error | state -> error where+  getErrors    ::  state   -> ([error], state)++pErrors :: Stores st error => P st [error]+pErrors = P ( \ 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' )+            Zero       -- this parser does not consume input+            (Just [])  -- the errors consumed cannot be determined statically! Hence we assume none.++-- ** 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.++pEnd    :: (Stores st error, Eof st) => P st [error]+pEnd    = P ( \ k inp ->   let deleterest inp =  case deleteAtEnd inp of+                                                    Nothing -> let (finalerrors, finalstate) = getErrors inp+                                                               in k  finalerrors finalstate+                                                    Just (i, inp') -> Fail []  [const (i,  deleterest inp')]+                           in deleterest inp)+            ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of+                                                    Nothing -> let (finalerrors, finalstate) = getErrors inp+                                                               in push finalerrors (k finalstate)+                                                    Just (i, inp') -> Fail [] [const ((i, deleterest inp'))]+                           in deleterest inp)+            ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of+                                                    Nothing -> let (finalerrors, finalstate) = getErrors inp+                                                               in  (k finalstate)+                                                    Just (i, inp') -> Fail [] [const (i, deleterest inp')]+                           in deleterest inp)+            Zero+            (error "Unforeseen use of pEnd function; pEnd should only be used in function running the actual parser")+++-- 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+parse :: (Eof t) => P t a -> t -> a+parse   (P _  pf _ _ _)  = fst . eval . pf  (\ rest   -> if eof rest then succeedAlways        else error "pEnd missing?")+parse_h (P ph _  _ _ _)  = fst . eval . ph  (\ a rest -> if eof rest then push a failAlways 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. +--   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.++pSwitch :: (st1 -> (st2, st2 -> st1)) -> P st2 a -> P st1 a+pSwitch split (P ph pf pr pl pe)    = P (\ k st1 ->  let (st2, back) = split st1+                                                     in ph (\ a st2' -> k a (back st2')) st2)+                                        (\ k st1 ->  let (st2, back) = split st1+                                                     in pf (\st2' -> k (back st2')) st2)+                                        (\ k st1 ->  let (st2, back) = split st1+                                                     in pr (\st2' -> k (back st2')) st2)+                                        pl+                                        pe +++-- ** A more efficient version for @`<$`@ from the module @`Control.Applicative`@+-- | In the new module `Control.Applicative' the operator `<$` is still hard coded. +--   We hide this import and provide an implementation using a class, which can be redfined when needed.++instance ExtApplicative (P st)  where+  f                <$   (P _  _  qr ql qe)   +    = P ( qr . ($f)) (\ k st -> push f (qr k st)) qr  ql  (case qe of Nothing -> Nothing; _ -> Just f)++-- * Maintaining Progress Information+-- | The data type @`Steps`@ is the core data type around which the parsers are constructed.+--   It is a describes a tree structure of streams containing (in an interleaved way) both the online result of the parsing process,+--   and progress information. Recognising an input token should correspond to a certain amount of @`Progress`@, +--   which tells how much of the input state was consumed. +--   The @`Progress`@ is used to implement the breadth-first search process, in which alternatives are+--   examined in a more-or-less synchonised way. The meaning of the various @`Step`@ constructors is as follows: -----   [@`Step`@] A token was succesfully recognised, and as a result the input was 'advanced' by the distance  `Progress`+--   [@`Step`@] A token was succesfully recognised, and as a result the input was 'advanced' by the distance  @`Progress`@ -- --   [@`Apply`@] The type of value represented by the `Steps` changes by applying the function parameter. -----   [@`Fail`@] A correcting step has to made to the input; the first parameter contains the error messages coresponding to the possible---   correcting steps, and the second parameter generated the various corrected alternatives, each with an associated `Cost`+--   [@`Fail`@] A correcting step has to made to the input; the first parameter contains information about what was expected in the input, +--   and the second parameter describes the various corrected alternatives, each with an associated `Cost` -----   The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report.+--   [@`Micro`@] A small cost is inserted in the sequence, which is used to disambiguate. Use with care!+--+--   The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report referred to from the README file..  type Cost = Int type Progress = Int+type Strings = [String]  data  Steps   a  where       Step   ::                 Progress       ->  Steps a                             -> Steps   a       Apply  ::  forall a b.    (b -> a)       ->  Steps   b                           -> Steps   a       Fail   ::                 Strings        ->  [Strings   ->  (Cost , Steps   a)]  -> Steps   a+      Micro   ::                 Cost           ->  Steps a                             -> Steps   a       End_h  ::                 ([a] , [a]     ->  Steps r)    ->  Steps   (a,r)       -> Steps   (a, r)       End_f  ::                 [Steps   a]    ->  Steps   a                           -> Steps   a +succeedAlways = let steps = Step 0 steps in steps failAlways  =  Fail [] [const (0, failAlways)] noAlts      =  Fail [] [] +-- ! @`eval`@ removes the progress information from a sequence of steps, and constructs the value contained in it.  eval :: Steps   a      ->  a eval (Step  _    l)     =   eval l-eval (Fail   ss  ls  )  =   eval (getCheapest 3 (map ($ss) ls)) +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) eval (End_f   _  _   )  =   error "dangling End_f constructor" eval (End_h   _  _   )  =   error "dangling End_h constructor" -push    :: v -> Steps   r -> Steps   (v, r)-push v  =  Apply (\ r -> (v, r))-apply   :: Steps (b -> a, (b, r)) -> Steps (a, r)-apply   =  Apply (\(b2a, ~(b, r)) -> (b2a b, r))  +push        :: v -> Steps   r -> Steps   (v, r)+push v      =  Apply (\ r -> (v, r))+apply       :: Steps (b -> a, (b, r)) -> Steps (a, r)+apply       =  Apply (\(b2a, ~(b, r)) -> (b2a b, r)) +pushapply   :: (b -> a) -> Steps (b, r) -> Steps (a, r)+pushapply f = Apply (\ (b, r) -> (f b, r))   norm ::  Steps a ->  Steps   a-norm     (Apply f (Step   p    l  ))   =   Step p (Apply f l)+norm     (Apply f (Step   p    l  ))   =   Step  p (Apply f l)+norm     (Apply f (Micro  c    l  ))   =   Micro c (Apply f l) norm     (Apply f (Fail   ss   ls ))   =   Fail ss (applyFail (Apply f) ls) norm     (Apply f (Apply  g    l  ))   =   norm (Apply (f.g) l) norm     (Apply f (End_f  ss   l  ))   =   End_f (map (Apply f) ss) (Apply f l)@@ -124,23 +351,28 @@     | n == m                              =   Step n (l `best'` r)          | n < m                               =   Step n (l  `best'`  Step (m - n)  r)     | n > m                               =   Step m (Step (n - m)  l  `best'` r)-End_f  as  l            `best'`  End_f  bs r     =   End_f (as++bs)  (l `best` r)-End_f  as  l            `best'`  r               =   End_f as        (l `best` r)-l                       `best'`  End_f  bs r     =   End_f bs        (l `best` r)+ls@(Step _  _)    `best'`  Micro _ _        =  ls+Micro _    _      `best'`  rs@(Step  _ _)   =  rs+ls@(Micro i l)    `best'`  rs@(Micro j r)  +    | i == j                               =   Micro i (l `best'` r)+    | i < j                                =   ls+    | i > j                                =   rs+End_f  as  l            `best'`  End_f  bs r          =   End_f (as++bs)  (l `best` r)+End_f  as  l            `best'`  r                    =   End_f as        (l `best` r)+l                       `best'`  End_f  bs r          =   End_f bs        (l `best` r) End_h  (as, k_h_st)  l  `best'`  End_h  (bs, _) r     =   End_h (as++bs, k_h_st)  (l `best` r)-End_h  as  l            `best'`  r               =   End_h as (l `best` r)-l                       `best'`  End_h  bs r     =   End_h bs (l `best` r)-l                       `best'`  r               =   l `best` r +End_h  as  l            `best'`  r                    =   End_h as (l `best` r)+l                       `best'`  End_h  bs r          =   End_h bs (l `best` r)+l                       `best'`  r                    =   l `best` r   -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% getCheapest  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% --- The function  getCheapest :: Int -> [(Int, Steps a)] -> Steps a  getCheapest _ [] = error "no correcting alternative found" getCheapest n l  =  snd $  foldr (\(w,ll) btf@(c, l)-                               ->    if w < c +                               ->    if w < c   -- c is the best cost estimate thus far, and w total costs on this path                                      then let new = (traverse n ll w c)                                            in if new < c then (new, ll) else btf                                      else btf @@ -148,185 +380,84 @@   traverse :: Int -> Steps a -> Int -> Int  -> Int -traverse 0  _               =  \ v c ->  v-traverse n (Step _  l)      =  traverse (n -  1 ) l-traverse n (Apply _ l)      =  traverse n         l-traverse n (Fail m m2ls)    =  \ v c ->  foldr (\ (w,l) c' -> if v + w < c' then traverse (n -  1 ) l (v+w) c'-                                                                            else c'-                                               ) c (map ($m) m2ls)+traverse 0  _                =  trace' ("traverse " ++ show 0 ++ "\n") (\ v c ->  v)+traverse n (Step _   l)      =  trace' ("traverse Step   " ++ show n ++ "\n") (traverse (n -  1 ) l)+traverse n (Micro _  l)      =  trace' ("traverse Micro  " ++ show n ++ "\n") (traverse n         l)+traverse n (Apply _  l)      =  trace' ("traverse Apply  " ++ show n ++ "\n") (traverse n         l)+traverse n (Fail m m2ls)     =  trace' ("traverse Fail   " ++ show n ++ "\n") (\ v c ->  foldr (\ (w,l) c' -> if v + w < c' then traverse (n -  1 ) l (v+w) c'+                                                                                                           else c'+                                                                                            ) c (map ($m) m2ls)+                                                                    ) traverse n (End_h ((a, lf))    r)  =  traverse n (lf a `best` removeEnd_h r)-traverse n (End_f (l      :_)  r)  =  traverse n (l `best` r)   ----- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Parsers     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%---- do not change into data, or be prepared to add ~ at subtle places !!-data  P   st  a =  P  (forall r . (a  -> st -> Steps r)  -> st -> Steps       r  )   -- history parser-                      (forall r . (      st -> Steps r)  -> st -> Steps   (a, r) )  -- future parser-                      (forall r . (      st -> Steps r)  -> st -> Steps       r  )          -- recogniser --instance   Functor (P  state) where -  fmap f   (P   ph pf pr)   =  P  ( \  k -> ph ( k .f ))-                                  ( \  k inp ->  Apply (\(a,r) -> (f a, r)) (pf k inp)) -- pure f <*> pf-                                  (pr) --instance   Applicative (P  state) where-  P ph pf pr <*> ~(P qh qf qr)  =  P  ( \  k -> ph (\ pr -> qh (\ qr -> k (pr qr))))-                                      ((apply .) . (pf .qf))-                                      ( pr . qr)  -  pure a                        =  P  ($a) ((push a).) id---instance   Alternative (P   state) where -  P ph pf pr  <|> P qh qf qr  =  P (\  k inp  -> ph k inp `best` qh k inp)-                                   (\  k inp  -> pf k inp `best` qf k inp)-                                   (\  k inp  -> pr k inp `best` qr k inp)-                                            -  empty                =  P  ( \  k inp  ->  noAlts)-                             ( \  k inp  ->  noAlts)-                             ( \  k inp  ->  noAlts)--instance  ( Provides state symbol token) => Symbol (P  state) symbol token where-  pSym a =  P ( \ k inp -> splitState a k inp)-              ( \ k inp -> splitState a (\ t inp' -> push t (k inp')) inp)-              ( \ k inp -> splitState a (\ _ inp' -> k inp') inp)--(<?>) :: P state a -> String -> P state a-P  ph  pf  pr  <?> label = P ( \ k inp -> replaceExpected  ( ph k inp))-                             ( \ k inp -> replaceExpected  ( pf k inp))-                             ( \ k inp -> replaceExpected  ( pr k inp))-                           where replaceExpected (Fail _ c) = (Fail [label] c)-                                 replaceExpected others     = others-      -data Id a = Id a deriving Show---- parse_h (P (ph, pf, pr)) = fst . eval . ph  (\ a rest -> if eof rest then push a failAlways else error "pEnd missing?") -parse (P ph pf pr) = fst . eval . pf  (\ rest   -> if eof rest then failAlways        else error "pEnd missing?")---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Monads      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--unParser_h (P  h   _  _  )  =  h-unParser_f (P  _   f  _  )  =  f-unParser_r (P  _   _  r  )  =  r-          --instance  Monad (P st) where-       P  ph pf pr  >>=  a2q = -                P  (  \k -> ph (\ a -> unParser_h (a2q a) k))-                   (  \k -> ph (\ a -> unParser_f (a2q a) k))-                   (  \k -> ph (\ a -> unParser_r (a2q a) k))-       return  = pure +traverse n (End_f (l      :_)  r)  =  traverse n (l `best` r)   -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Greedy      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Handling ambiguous paths             %%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -best_gr :: Steps a -> Steps a -> Steps a--l@  (Step _ _)   `best_gr` _  = l-l                `best_gr` r  = l `best` r--P ph pf pr <<|> P qh qf qr  = P ( \ k st  -> norm (ph k st) `best_gr` norm (qh k st))-                                ( \ k st  -> norm (pf k st) `best_gr` norm (qf k st))-                                ( \ k st  -> norm (pr k st) `best_gr` norm (qr k st))---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Ambiguous   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-amb :: P st a -> P st [a]--amb (P ph pf pr) = P ( \k     ->  removeEnd_h . ph (\ a st' -> End_h ([a], \ as -> k as st') noAlts))-                     ( \k inp ->  combinevalues . removeEnd_f $ pf (\st -> End_f [k st] noAlts) inp)-                     ( \k     ->  removeEnd_h . pr (\ st' -> End_h ([undefined], \ _ -> k  st') noAlts))- removeEnd_h     :: Steps (a, r) -> Steps r removeEnd_h (Fail  m ls             )  =   Fail m (applyFail removeEnd_h ls) removeEnd_h (Step  ps l             )  =   Step  ps (removeEnd_h l) removeEnd_h (Apply f l              )  =   error "not in history parsers"+removeEnd_h (Micro c l              )  =   Micro c (removeEnd_h l) removeEnd_h (End_h  (as, k_st  ) r  )  =   k_st as `best` removeEnd_h r   removeEnd_f      :: Steps r -> Steps [r] removeEnd_f (Fail m ls)        =   Fail m (applyFail removeEnd_f ls) removeEnd_f (Step ps l)        =   Step ps (removeEnd_f l)-removeEnd_f (Apply f l)        =   Apply (map' f) (removeEnd_f l)+removeEnd_f (Apply f l)        =   Apply (map' f) (removeEnd_f l) +                                   where map' f ~(x:xs)  =  f x : map f xs+removeEnd_f (Micro c l      )  =   Micro c (removeEnd_f l) removeEnd_f (End_f(s:ss) r)    =   Apply  (:(map  eval ss)) s                                                   `best`                                           removeEnd_f r--combinevalues  :: Steps [(a,r)] -> Steps ([a],r)-combinevalues lar           =   Apply (\ lar -> (map fst lar, snd (head lar))) lar-map' f ~(x:xs)              =   f x : map f xs-        -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% pErrors     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Auxiliary Functions and Types        %%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -class state `Stores`  errors | state -> errors where-  getErrors    ::  state   -> (errors, state)+trace' v m = m  -pErrors :: Stores st errors => P st errors-pEnd    :: (Stores st errors, Eof st) => P st errors+-- * Auxiliary functions and types+-- ** Checking for non-sensical combinations: @`must_be_non_empty`@ and @`must_be_non_empties`@+-- | The function checks wehther its second argument is a parser which can recognise the mety sequence. If so an error message is given+--   using the name of the context. If not then the third argument is returned. This is useful in testing for loogical combinations. For its use see+--   the module Text>parserCombinators.UU.Derived -pErrors = P ( \ 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' )+must_be_non_empty :: [Char] -> P t t1 -> t2 -> t2+must_be_non_empty msg p@(P _ _ _ _ (Just _ )) _ +            = error ("The combinator " ++ msg ++ "\n" +++                     "    requires that it's argument cannot recognise the empty string\n")+must_be_non_empty _ _  q  = q -pEnd    = P ( \ k inp -> let deleterest inp =  case deleteAtEnd inp of-                                                  Nothing -> let (finalerrors, finalstate) = getErrors inp-                                                             in k  finalerrors finalstate-                                                  Just (i, inp') -> Fail []  [const (i,  deleterest inp')]-                        in deleterest inp)-            ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of-                                                    Nothing -> let (finalerrors, finalstate) = getErrors inp-                                                               in push finalerrors (k finalstate)-                                                    Just (i, inp') -> Fail [] [const ((i, deleterest inp'))]-                           in deleterest inp)-            ( \ k   inp -> let deleterest inp =  case deleteAtEnd inp of-                                                    Nothing -> let (finalerrors, finalstate) = getErrors inp-                                                               in  (k finalstate)-                                                    Just (i, inp') -> Fail [] [const (i, deleterest inp')]-                           in deleterest inp)+-- | This function is similar to the above, but can be used in situations where we recognise a sequence of elements separated by other elements. This does not +--   make sense if both parsers can recognise the empty string. Your grammar is then highly ambiguous. -{---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Microsteps  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+must_be_non_empties :: [Char] -> P t1 t -> P t3 t2 -> t4 -> t4+must_be_non_empties  msg (P _ _ _ _ (Just _ )) (P _ _ _ _ (Just _ )) _ +            = error ("The combinator " ++ msg ++ "\n" +++                     "    requires that not both arguments can recognise the empty string\n")+must_be_non_empties  msg _  _ q = q +-- ** 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. -class MicroStep result where-  microstep :: result a -> result a+data Nat = Zero+         | Succ Nat+         | Infinite+         deriving  Show -instance MicroStep Steps where-   microstep steps = Micro steps+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)  = trace' "Succs in nat_min\n"         (let (v, b) = ll `nat_min` rr in (Succ v, b)) -class Micro p where-  micro :: p a -> p a+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)) -instance  Micro (P_f  st) where-  micro (P_f p) = P_f (\k st -> microstep ( p k st ) )--}+get_length (P _ _ _ l _) = l --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% State Change          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -pSwitch :: (st1 -> (st2, st2 -> st1)) -> P st2 a -> P st1 a --pSwitch split (P ph pf pr)    = P (\ k st1 ->  let (st2, back) = split st1-                                               in ph (\ a st2' -> k a (back st2')) st2)-                                  (\ k st1 ->  let (st2, back) = split st1-                                                  in pf (\st2' -> k (back st2')) st2)-                                  (\ k st1 ->  let (st2, back) = split st1-                                                  in pr (\st2' -> k (back st2')) st2)--instance ExtApplicative (P st)  where-  P ph pf pr <*  ~(P _  _  qr)   = P ( ph. (qr.)) (pf. qr)    (pr . qr)  -  P _  _  pr *>  ~(P qh qf qr)   = P ( pr . qh  ) (pr. qf)    (pr . qr)-  f          <$  ~(P _  _  qr)   = P ( qr . ($f)) (\ k st -> push f (qr k st)) qr --type Strings = [String]

@@ -10,6 +10,9 @@ module Text.ParserCombinators.UU.Derived where import Text.ParserCombinators.UU.Core +-- | This module contains a large variety of combinators for list-lile structures. the extension @_ng@ indiactes that that varinat is the non-greedy variant.+--   See the "Text.ParserCombinators.UU.Examples" module for some exmaples of their use.+ pReturn  = pure pFail    = empty @@ -50,78 +53,76 @@ -- ======================================================================================= 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 = pfm where pfm = (op <$> p <*> pfm) `opt` e-pFoldr_ng      alg@(op,e)     p = pfm where pfm = (op <$> p <*> pfm)  <|> pure e+pFoldr         alg@(op,e)     p =  must_be_non_empty "pFoldr" p pfm+                                   where pfm = (op <$> p <*> pfm) `opt` e+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 = op <$> p <*> pFoldr  alg p-pFoldr1_ng     alg@(op,e)     p = op <$> p <*> pFoldr_ng  alg p+pFoldr1        alg@(op,e)     p =  must_be_non_empty "pFoldr1"    p (op <$> p <*> pFoldr     alg p) +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 = op <$> p <*> pFoldr    alg sepp `opt` e-                                  where sepp = sep *> p-pFoldrSep_ng   alg@(op,e) sep p = op <$> p <*> pFoldr_ng alg sepp <|>  pure e-                                  where sepp = sep *> p+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   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 = pfm where pfm = op <$> p <*> pFoldr    alg (sep *> p)-pFoldr1Sep_ng  alg@(op,e) sep p = pfm where pfm = op <$> p <*> pFoldr_ng alg (sep *> p)+pFoldr1Sep     alg@(op,e) sep p =  must_be_non_empties "pFoldr1Sep"    sep   p pfm+                                   where pfm = op <$> p <*> pFoldr    alg (sep *> p)+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)  list_alg :: (a -> [a] -> [a], [a1]) list_alg = ((:), [])  pList    ::    P st a -> P st [a] pList_ng ::    P st a -> P st [a]-pList         p = pFoldr        list_alg   p-pList_ng      p = pFoldr_ng     list_alg   p+pList         p =  must_be_non_empty "pList"    p (pFoldr        list_alg   p)+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 = pFoldr1       list_alg   p-pList1_ng      p = pFoldr1_ng    list_alg   p+pList1         p =  must_be_non_empty "pList"    p (pFoldr1       list_alg   p)+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 = pFoldrSep     list_alg sep p-pListSep_ng   sep p = pFoldrSep_ng  list_alg sep p+pListSep      sep p = must_be_non_empties "pListSep"    sep   p (pFoldrSep     list_alg sep p)+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 = pFoldr1Sep    list_alg s p-pList1Sep_ng  s p = pFoldr1Sep_ng list_alg s p+pList1Sep     s p =  must_be_non_empties "pListSep"    s   p (pFoldr1Sep    list_alg s p)+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    =  r where r = x <??> (flip <$> op <*> r)-pChainr_ng op x    =  r where r = x <**> ((flip <$> op <*> r)  <|> pure id)+pChainr    op x    =   must_be_non_empties "pChainr"    op   x r where r = x <??> (flip <$> op <*> r)+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    = f <$> x <*> pList (flip <$> op <*> x) +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 op x    = f <$> x <*> pList_ng (flip <$> op <*> x) +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 --- | Parses using any of the parsers in the list 'l'.-+-- | Build a parser for each elemnt in its argument list and tries them all. pAny :: (a -> P st a1) -> [a] -> P st a1 pAny  f l =  foldr (<|>) pFail (map f l)  -- | Parses any of the symbols in 'l'. pAnySym :: Provides st s s => [s] -> P st s pAnySym = pAny pSym --pToken :: Provides st s s => [s] -> P st [s]-pToken []     = pure []-pToken (a:as) = (:) <$> pSym a <*> pToken as--pAnyToken ::  Provides st s s => [[s]] -> P st [s]-pAnyToken = pAny pToken 

@@ -1,66 +1,252 @@-{-# LANGUAGE  RankNTypes, -              GADTs,-              MultiParamTypeClasses,-              FunctionalDependencies, -              FlexibleInstances, -              FlexibleContexts, -              UndecidableInstances,-              NoMonomorphismRestriction#-}-+{-# LANGUAGE  RankNTypes #-}+--              GADTs,+--              MultiParamTypeClasses,+--              FunctionalDependencies, +--              FlexibleInstances, +--              FlexibleContexts, +--              UndecidableInstances,+--              NoMonomorphismRestriction module Text.ParserCombinators.UU.Examples where import Char-import Text.ParserCombinators.UU.Parsing+import Text.ParserCombinators.UU -type Pars a = P (Str Char) a -test :: Pars a -> String -> (a, [Error Char Char Int]) -test p inp = parse ( (,) <$> p <*> pEnd) (listToStr inp)+-- |We start out by defining the type of parser we want; by specifying the type of the state we resolve a lot of overloading -lift a = [a]+type Parser a = P (Str Char) a  -pa, pb, paz ::Pars [Char] -pa = lift <$> pSym 'a'+-- | The fuction @`run`@ runs the parser and shows both the result, and the correcting steps which were taken during the parsing process.+run :: Show t =>  P (Str Char) t -> String -> IO ()+run p inp = do  let r@(a, errors) =  parse ( (,) <$> p <*> pEnd) (listToStr inp)+                putStrLn "--"+                putStrLn "-- @"+                putStrLn ("-- Result: " ++ show a)+                if null errors then  return ()+                               else  do putStr ("-- Correcting steps: \n")+                                        show_errors errors+                putStrLn "-- @"+++-- | Our first two parsers are simple; one recognises a single 'a' character and the other one a single 'b'. Since we will use them later we +--   convert the recognsied character into String so they can be easily combined.+pa  ::Parser String +pa  = lift <$> pSym 'a'+pb  :: Parser String  pb = lift <$> pSym 'b'+lift a = [a]++-- | We can now run the parser @`pa`@ on input \"a\", which succeeds: +--+-- @ +--   Result: \"a\"+-- @++test1 = run pa "a"++-- | If we   run the parser @`pa`@ on the empty input \"\", the expected symbol in inserted, that the position where it was inserted is reported, and+--   we get information about what was expected at that position:  @run pa \"\"@ +--+-- @+-- Result: \"a\"+-- Correcting steps: +--     Inserted 'a' at position 0 expecting 'a'+-- @++test2 = run pa ""++-- | Now let's see what happens if we encounter an unexpected symbol, as in @run pa \"b\"@:+--+-- @+-- Result: \"a\"+-- Correcting steps: +--     Deleted  'b' at position 0 expecting 'a'+--     Inserted 'a' at position 1 expecting 'a'+-- @++test3 = run pa "b"++-- | The combinator @\<++>@ applies two parsers sequentially to the input and concatenates their results: @run (pa <++> pa) \"aa\"@:+--+-- @+-- Result: \"aa\"+-- @++(<++>) :: Parser String -> Parser String -> Parser String p <++> q = (++) <$> p <*> q pa2 =   pa <++> pa pa3 =   pa <++> pa2 -pCount p = (\ a b -> b+1) <$> p <*> pCount p <<|> pReturn 0-pExact 0 p = pReturn []-pExact n p = (:) <$> p <*> pExact (n-1) p+test4 = run pa2 "aa" +-- | The function @`pSym`@ is overloaded. The type of its argument determines how to interpret the argument. Thus far we have seen single characters, +--   but we may pass ranges as well as argument: @\run (pList (pSym ('a','z'))) \"doaitse\"@+--+-- @+-- Result: "doaitse"+-- @++test5 =  run  (pList (pSym ('a','z'))) "doaitse" paz = pList (pSym ('a', 'z')) +-- | An even more general instance of @`pSym`@ takes a triple as argument: a predicate, a string  indicating what is expected, +--   and the value to insert if nothing can be recognised: @run (pSym (\t -> 'a' <= t && t <= 'z', \"'a'..'z'\", 'k')) \"v\"@+--+-- @+-- Result: 'k'+-- Correcting steps: +--     Deleted  '1' at position 0 expecting 'a'..'z'+--     Inserted 'k' at position 1 expecting 'a'..'z'+-- @++test6 = run  paz' "1" paz' = pSym (\t -> 'a' <= t && t <= 'z', "'a'..'z'", 'k') -main :: IO ()-main = do print (test pa "a")-          print (test pa "b")-          print (test pa2 "bbab")-          print (test pa "ba")-          print (test pa "aa")-          print (test  (do  l <- pCount pa-                            pExact l pb) "aaacabbb")-          print (test (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2))  "aaabaa")-          print (test paz "ab1z7")-          print (test paz' "m")-          print (test paz' "")-          print (test (pa <|> pb <?> "just a message") "c")-          print (test parseBoth "(123;456;789)")-          print (test munch "a^^&&**^^&b")+-- | The parser `pCount` recognises a sequence of elements, throws away the results of the recognition process (@ \<$ @), and just returns the number of returned elements.+--   The choice combinator @\<\<|>@ indicates that prefernce is to be given to the left alternative if it can make progress. This enables us to specify greedy strategies:+--   @ run (pCount pa) \"aaaaa\"@+--+-- @+-- Result: 5+-- @ -munch = (,,) <$> pa <*> pMunch ( `elem` "^&*") <*> pb+pCount p = (+1) <$ p <*> pCount p <<|> pReturn 0 --- bracketing expressions-pParens p =  pSym '(' *> p <* pSym ')'-pBracks p =  pSym '[' *> p <* pSym ']'-pCurlys p =  pSym '{' *> p <* pSym '}'+test7 = run (pCount pa) "aaaaa" +-- | The parsers are instance of the class Monad and hence we can use the result of a previous parser to construct a following one:  @run (do  {l <- pCount pa; pExact l pb}) \"aaacabbb\"@+--+-- @+-- Result: [\"b\",\"b\",\"b\",\"b\"]+-- Correcting steps: +--     Deleted  'c' at position 3 expecting one of ['a', 'b']+--     Inserted 'b' at position 8 expecting 'b'+-- @+++test8 = run (do  {l <- pCount pa; pExact l pb}) "aaacabbb"+pExact 0 p = pReturn []+pExact n p = (:) <$> p <*> pExact (n-1) p++-- | The function @`amb`@ converts an ambigous parser into one which returns all possible parses: @run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2))  \"aaaaa\"@+--+-- @+-- Result: [\"aaaaa\",\"aaaaa\"]+-- @++test9 = run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2))  "aaaaa"++-- | The applicative style makes it very easy to merge recognsition and computing a result. As an example we parse a sequence of nested well formed parentheses pairs a,d+--   compute the maximum nesting depth: @run ( max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0) \"((()))()(())\" @+--+-- @+-- Result: 3+-- @++test10 = run wfp "((()))()(())"+wfp =  max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0++-- | It is very easy to recognise infix expressions with any number of priorities and operators:+--+-- @ +-- pOp (c, op) = op <$ pSym c+-- sepBy p op = pChainl op p+-- expr    = foldr sepBy factor [(pOp ('+', (+)) <|> pOp ('-', (-))),  pOp ('*' , (*))] +-- factor  = pNatural <|> pParens expr+-- @+-- +-- | which we can call:  @run expr \"15-3*5\"@+--+-- @+-- Result: 0+-- @+--+-- | Note that also here correction takes place: @run expr \"2 + + 3 5\"@+--+-- @+-- Result: 37+-- Correcting steps: +--     Deleted  ' ' at position 1 expecting one of ['0'..'9', '*', '-', '+']+--     Inserted '0' at position 3 expecting one of ['(', '0'..'9']+--     Deleted  ' ' at position 4 expecting one of ['(', '0'..'9']+--     Deleted  ' ' at position 6 expecting one of ['0'..'9', '*', '-', '+']+-- @+++test11 = run expr "15-3*5"++-- parsing expressions+pOp (c, op) = op <$ pSym c+expr    = foldr pChainl factor [(pOp ('+', (+)) <|> pOp ('-', (-))),  pOp ('*' , (*))] +factor  = pNatural <|> pParens expr -- parsing numbers+pDigit :: Parser Char pDigit = pSym ('0', '9') pDigitAsInt = digit2Int <$> pDigit  pNatural = foldl (\a b -> a * 10 + b ) 0 <$> pList1 pDigitAsInt digit2Int a =  ord a - ord '0' +-- | A common case where ambiguity arises is when we e.g. want to recognise identifiers, but only those which are not keywords. +--   The combinator `micro` inserts steps with a specfied cost in the result of the parser which can be used to disambiguate:+--+-- @+-- ident ::  Parser String+-- ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces+-- idents = pList1 ident+-- pKey keyw = pToken keyw `micro` 1 <* spaces+-- spaces :: Parser String+-- spaces = pMunch (==' ')+-- takes_second_alt =   pList ident +--                \<|> (\ c t e -> [\"IfThenElse\"] ++  c   ++  t  ++  e) +--                    \<$ pKey \"if\"   \<*> pList_ng ident +--                    \<* pKey \"then\" \<*> pList_ng ident+--                    \<* pKey \"else\" \<*> pList_ng ident  +-- @+--++-- | A keyword is followed by a small cost @1@, which makes sure that identifiers which have a keyword as a prefix win over the keyword. Identifiers are however+--   followed by a cost @2@, with as result that in this case the keyword wins. +--   Note that a limitation of this approach is that keywords are only recognised as such when expected!+-- +-- @+-- test13 = run takes_second_alt \"if a then if else c\"+-- test14 = run takes_second_alt \"ifx a then if else c\"+-- @+-- +-- with results:+--+-- @+-- Text.ParserCombinators.UU.Examples> test14+-- Result: [\"IfThenElse\",\"a\",\"if\",\"c\"]+-- Text.ParserCombinators.UU.Examples> test14+-- Result: [\"ifx\",\"a\",\"then\",\"if\",\"else\",\"c\"]+-- @+++ident ::  Parser String+ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces+idents = pList1 ident++pKey keyw = pToken keyw `micro` 1 <* spaces+spaces :: Parser String+spaces = pMunch (==' ')+ +takes_second_alt =   pList ident +              <|> (\ c t e -> ["IfThenElse"] ++  c   ++  t  ++  e) +                  <$ pKey "if"   <*> pList_ng ident +                  <* pKey "then" <*> pList_ng ident+                  <* pKey "else" <*> pList_ng ident  +test13 = run takes_second_alt "if a then if else c"+test14 = run takes_second_alt "ifx a then if else c"++++munch = (,,) <$> pa <*> pMunch ( `elem` "^=*") <*> pb++-- bracketing expressions+pParens :: Parser a -> Parser a+pParens p =  pSym '(' *> p <* pSym ')'+pBracks p =  pSym '[' *> p <* pSym ']'+pCurlys p =  pSym '{' *> p <* pSym '}'+ -- parsing letters and identifiers pLower  = pSym ('a','z') pUpper  = pSym ('A','Z')@@ -69,39 +255,34 @@ pConId  = (:) <$> pUpper <*> pList pIdChar pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='" +pAnyToken :: [String] -> Parser String+pAnyToken = pAny pToken+ -- parsing two alternatives and returning both rsults pAscii = pSym ('\000', '\254')-pIntList       ::Pars [Int] +pIntList       ::Parser [Int]  pIntList       =  pParens ((pSym ';') `pListSep` (read <$> pList (pSym ('0', '9'))))-parseIntString :: Pars String+parseIntString :: Parser String parseIntString = pList (pAscii)  parseBoth = pPair pIntList parseIntString  pPair p q =  amb (Left <$> p <|> Right <$> q) --- running the parser; if complete input accepted return the result else fail with reporting unconsumed tokens-run :: forall t. P (Str Char) t -> String -> t-run p i = do let (a,b) = exec p i-             if null b then a else error (show b)+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" -exec :: P (Str Char) b -> String -> (b, [Error Char Char Int])-exec p inp = parse ( (,) <$> p <*> pEnd) (listToStr inp)  --- Testing-pTest_MS :: P (Str Char) Char-pTest_MS = id <$ pSym 'u' <*> pSym '2'--pOp (c, op) = op <$ pSym c--sepBy p op = pChainl op p-expr    = term   `sepBy` (pOp ('+', (+)) <|> pOp ('-', (-)))-term    = factor `sepBy` pOp ('*' , (*))-factor  = pNatural <|> pSym '(' *> expr <* pSym ')'--rune ::  String -> IO ()-rune i = do let (a,b) = exec expr i-            if null b then  print ("Result: " ++ show a)-                      else do print b-                              print ("Result: " ++ show a)

@@ -1,6 +1,7 @@-module Text.ParserCombinators.UU.Parsing ( module Text.ParserCombinators.UU.Core-                                         , module Text.ParserCombinators.UU.BasicInstances-                                         , module Text.ParserCombinators.UU.Derived) where+module Text.ParserCombinators.UU.Parsing  {-# DEPRECATED "Use Text.ParserCombinators.UU instead" #-}+        ( module Text.ParserCombinators.UU.Core+        , module Text.ParserCombinators.UU.BasicInstances+        , module Text.ParserCombinators.UU.Derived) where import Text.ParserCombinators.UU.Core import Text.ParserCombinators.UU.BasicInstances import Text.ParserCombinators.UU.Derived

@@ -1,69 +1,39 @@ Name:                uu-parsinglib-Version:             2.3.4+Version:             2.4.0 Build-Type:          Simple-License:             MIT +License:             MIT+Copyright:           S Doaitse Swierstra  License-file:        LICENSE-Author:              Doaitse Swierstra-Maintainer:          doaitse@swierstra.net       +Extra-source-files:  CHANGELOG, README+Author:              Doaitse Swierstra, Utrecht University+Maintainer:          Doaitse Swierstra        Stability:           stable, but evolving Homepage:            http://www.cs.uu.nl/wiki/bin/view/HUT/ParserCombinators Bug-reports:         mailto:doaitse@swierstra.net-Synopsis:            New version of the Utrecht University parser combinator library        +Synopsis:            Online, error-correcting parser combinators; monadic and applicative interfaces        Cabal-Version:       >=1.4-Description:         New version of the Utrecht University parser combinator library, providing online, error correction, -                     annotation free, applicative style parser combinators which also provides a monadic interface+Description:         New version of the Utrecht University parser combinator library, which  provides online, error correction, +                     annotation free, applicative style parser combinators. In addition to this we even  provide a monadic interface.+                     Parsers do analyse themselves to avoid commonly made errors                      .                      The file Text.ParserCombinators.UU.Examples contains a ready-made main function,-                     which can be called to see the error correction at work.-                     .-                    -                     .-                     Versions above 2.1: -                     .-                     * based on Control.Applicative-                     .-                     Versions above 2.2:-                     .-                     *  make use of type families   -                     *  contain a module with many list-based derived combinators-                     .-                     Version 2.3.1-                     .-                     * fix for GHC 6.12, because of change in GADT definition handling-                     .-                     Version 2.3.2-                     .-		     * added microsteps, which can be used to disambiguate-                     .-                     Version 2.3.3-                     .-                     * added pMunch which takes a Boolean function, and recognises the longest prefix for which the symbols match the predicate -                     .-                     * added the infix operator with piority 2 <?> :: P state a -> String -> P st a which replaces the list of expected symbols-                       in error message by its right argument String-                     .-                     Version 2.3.4-                     .-                     * removed dependecies on impredictaive types, preparing for next GHC version-                     .-                     Future versions above 2.3+                     which can be called to see the error correction at work. It contains extensive haddock documentation; +                     try all the small tests for yourself to see the correction process at work, and to get a +                     feeling for how to use the various combinators.                      .-                     * contain some form of abstract interpretation from the old uulib versions of these combinators+                     The file CHANGELOG which is distributed with the pacakge describes the list of changes and additions                      .-                     * are closer to Haskell98, since they do not make use of type families anymore+                     The file README contains some references to background information                      .-                     * note that the basic parser interface will probably not change much when we add more features, but the calling conventions-                       of the outer parser and the class structure upon which the parametrisation is based may change-                     . -                     -Category:            ParserCombinators Parsing Text+Category:            Parsing  Library   hs-source-dirs:    src    Build-Depends:     base >= 4 && <5, haskell98-  Exposed-modules:   Text.ParserCombinators.UU.Parsing +  Exposed-modules:   Text.ParserCombinators.UU                      Text.ParserCombinators.UU.Core                        Text.ParserCombinators.UU.BasicInstances                      Text.ParserCombinators.UU.Derived                       Text.ParserCombinators.UU.Examples+                     Text.ParserCombinators.UU.Parsing