uu-parsinglib 2.1.0 → 2.2.0

raw patch · 6 files changed

+586/−442 lines, 6 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/ParserCombinators/UU/BasicInstances.hs +1/−1
• Text/ParserCombinators/UU/Core.hs +425/−0
• Text/ParserCombinators/UU/Derived.hs +110/−0
• Text/ParserCombinators/UU/Examples.hs +10/−30
• Text/ParserCombinators/UU/Parsing.hs +6/−407
• uu-parsinglib.cabal +34/−4

@@ -12,7 +12,7 @@ -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%  module Text.ParserCombinators.UU.BasicInstances where-import Text.ParserCombinators.UU.Parsing+import Text.ParserCombinators.UU.Core  data Error t s pos = Inserted s pos Strings                    | Deleted  t pos Strings

@@ -0,0 +1,425 @@++{-# LANGUAGE  RankNTypes, +              GADTs,+              MultiParamTypeClasses,+              FunctionalDependencies, +              FlexibleInstances, +              FlexibleContexts, +              UndecidableInstances,+              NoMonomorphismRestriction,+              TypeFamilies#-}+++module Text.ParserCombinators.UU.Core ( module Text.ParserCombinators.UU.Core+                                              , module Control.Applicative) where+import Control.Applicative  hiding ((<*), (*>), (<$), many, some, optional)+import Char+import Debug.Trace+import Maybe++infixl  4  <*, *>+infixl  4  <$++ap f a = f a ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Classes     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++class    (ExtApplicative p, Alternative p, Greedy p)    => Parser p where+instance (ExtApplicative p, Alternative p, Greedy p)    => Parser p where+++pReturn  = pure+pFail    = empty++class  Symbol p  symbol token | symbol -> token where+  pSym  ::  symbol -> p token++type Strings = [String]++type Cost = Int+type Progress = Int++class  Provides state symbol token | state symbol -> token  where+       splitState   ::  symbol -> (token -> state  -> Steps a) -> state -> Steps a++class Eof state where+       eof          ::  state   -> Bool+       deleteAtEnd  ::  state   -> Maybe (Cost, state)++class  Parse p  where+       parse  ::   Eof state => p state a -> state -> a++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Steps      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++data  Steps   a  where+      Step   ::              Progress       ->  Steps a                                -> Steps   a+      Fail   ::              [String]       ->  [[String]  ->       (Int, Steps   a)]  -> Steps   a+      Apply  ::  forall b.   (b -> a)       ->  Steps   b                              -> Steps   a+      End_h  ::              ([a] , [a] -> Steps r)        ->  Steps   (a,r)           -> Steps   (a, r)+      End_f  ::              [Steps   a]   ->  Steps   a                               -> Steps   a++failAlways  =  Fail [] [const ((0, failAlways))]+noAlts      =  Fail [] []++eval :: Steps   a      ->  a+eval (Step  _    l)     =   eval l+eval (Fail   ss  ls  )  =   eval (getCheapest 3 [f ss | f <- ls]) +eval (Apply  f   l   )  =   f (eval l)+eval (End_f   _  _   )  =   error "dangling End_fconstructor"+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))  ++norm ::  Steps a ->  Steps   a+norm     (Apply f (Step   p    l  ))   =   Step p (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)+norm     (Apply f (End_h  _    _  ))   =   error "Apply before End_h"+norm     steps                         =   steps++applyFail f  = map (\ g -> \ ex -> let (c, l) =  g ex in  (c, f l))++best :: Steps   a -> Steps   a -> Steps   a+x `best` y =   norm x `best'` norm y++best' :: Steps   b -> Steps   b -> Steps   b+Fail  sl  ll     `best'`  Fail  sr rr     =   Fail (sl ++ sr) (ll++rr)+Fail  _   _      `best'`  r               =   r+l                `best'`  Fail  _  _      =   l+Step  n   l      `best'`  Step  m  r+    | 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)+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 ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% History     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++-- do not change into data !!+newtype  P_h    st  a =  P_h  (forall r . (a  -> st -> Steps r)  -> st -> Steps r)+unP_h (P_h p) = p++instance   Functor (P_h  state) where +  fmap f      (P_h p)  =  P_h  (\  k -> p (\a -> k (f a))) ++instance   Applicative (P_h  state) where+  (P_h p) <*> (P_h q)  =  P_h  (\  k -> p (\ f -> q (\ a -> k (f a))))  +  pure a               =  P_h  (\  k -> k a)++instance   Alternative (P_h  state) where +  (P_h p) <|> (P_h q)  =  P_h  (\  k inp  -> p k inp `best` q k inp) +  empty                =  P_h  (\  k -> const noAlts) ++instance  ( Provides state symbol token) => Symbol (P_h  state) symbol token where+  pSym a =  P_h (splitState a)++data Id a = Id a deriving Show++instance   Parse P_h  where+  parse (P_h p)+   =  fst . eval . p  (\ a rest -> if eof rest then push a failAlways else error "pEnd missing?") ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Future      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++-- do not change into data !!+newtype  P_f st a  = P_f (forall r . (st -> Steps   r) -> st -> Steps   (a, r))+unP_f (P_f p) = p++instance  Functor (P_f st) where+ fmap f (P_f p)     =  P_f (\k inp ->  Apply (\(a,r) -> (f a, r)) (p k inp)) -- \pure f <*> p++instance Applicative (P_f st) where+ P_f p  <*>  P_f q  =   P_f ( (apply .) . (p .q)) + pure a             =   P_f ((push a).)++instance Alternative (P_f st) where+ P_f p  <|>  P_f q  =   P_f (\ k inp  -> p k inp `best` q k inp)  + empty              =   P_f (\ k inp  -> noAlts)+++instance  (Provides state symbol token) =>  Symbol (P_f  state) symbol token where+  pSym a =  P_f (\ k inp-> splitState a (\ t inp' -> push t (k inp')) inp)++instance  Parse P_f  where+  parse (P_f p) =  fst . eval . p (\ rest -> if eof rest then failAlways else error "pEnd missing")++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Monads      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++infixr 1 >>>=+class GenMonad  m_1 m_2 where+   (>>>=) :: m_1 b -> ( b -> m_2  a) -> m_2 a++instance     Monad (P_h  state) +         =>  GenMonad (P_h  state) (P_h state) where+  (>>>=)  = (>>=) --  the monadic bind defined before++instance GenMonad (P_h  state) (P_f  state) where+  (P_h p)  >>>= pv2q +           = P_f (\ k st -> p (\ pv st -> unP_f (pv2q pv) k st) st)++newtype P_m state a = P_m (P_h  state a, P_f state a) +unP_m_h (P_m  (P_h h,  _    ))  =  h+unP_m_f (P_m  (_    ,  P_f f))  =  f++instance  (   Functor (P_h  st), Functor (P_f  st)) +          =>  Functor (P_m  st) where+ fmap f  (P_m (hp, fp))  = P_m  (fmap f hp, fmap f fp)      ++instance  (   Applicative (P_h  st), Applicative (P_f  st)) +          =>  Applicative (P_m  st) where+ P_m (hp, fp)  <*> ~(P_m (hq, fq))    = P_m  (hp <*> hq, fp <*> fq)+ pure a                               = P_m  (pure a, pure a)       ++instance  (   Alternative (P_h  st), Alternative (P_f  st)) +          =>  Alternative (P_m  st) where + P_m (hp, fp)  <|> P_m (hq, fq)    = P_m  (hp <|> hq, fp <|> fq)+ empty                             = P_m  (empty,         empty)       ++instance  (Provides state symbol token)  => Symbol (P_m state) symbol token where+  pSym a =  P_m (pSym a, pSym a)++instance   Parse P_m  where+  parse (P_m (_, (P_f fp)))  +      =  fst . eval. fp (\ rest -> if eof rest  then failAlways else error "End_fmissing?") ++instance Applicative (P_h state) => Monad (P_h state) where+  P_h p >>= a2q  = P_h ( \ k -> p (\ a -> unP_h (a2q a) k))+  return     = pure++instance Applicative (P_m st) => Monad (P_m st) where+     P_m  (P_h p, _)  >>=  a2q = +           P_m  (  P_h   (\k -> p (\ a -> unP_m_h (a2q a) k))+                ,  P_f   (\k -> p (\ a -> unP_m_f (a2q a) k))+                )+     return  = pure ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Greedy      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++best_gr :: Steps a -> Steps a -> Steps a++l@  (Step _ _)   `best_gr` _  = l+l                `best_gr` r  = l `best` r++class  Greedy p where +  (<<|>) :: p a -> p a -> p a++instance Greedy (P_h state)  where+  P_h p <<|> P_h q = P_h (\ k st  -> norm (p k st) `best_gr` norm (q k st))++instance Greedy (P_f state)  where+  P_f p <<|> P_f q = P_f (\ k st  -> norm (p k st) `best_gr` norm (q k st))++instance Greedy (P_m state) where+    P_m (hp, fp)  <<|> P_m (hq, fq) = P_m  (hp <<|> hq, fp <<|> fq) +++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Ambiguous   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++class Ambiguous p where+ amb :: p a -> p [a]++instance Ambiguous (P_h state) where+  amb (P_h p) = P_h ( \k ->  removeEnd_h . p (\ a st' -> End_h ([a], \ as -> k as 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 (End_h  (as, k_st  ) r  )  =   k_st as `best` removeEnd_h r +++instance Ambiguous (P_f state) where+  amb (P_f p) = P_f (\k inp -> combinevalues . removeEnd_f $ p (\st -> End_f [k st] noAlts) inp)+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 (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++instance (Ambiguous (P_h state), Ambiguous (P_f state)) => Ambiguous (P_m state) where+  amb  (P_m (hp, fp))  = P_m (amb hp, amb fp)+       +-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% getCheapest  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++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 +                                     then let new = (traverse n ll w c) +                                          in if new < c then (new, ll) else btf+                                     else btf +                               )   (maxBound, error "getCheapest") l+++traverse :: Int -> Steps a -> Int -> Int -> Int+traverse 0 _                =  \ v c ->  v+traverse n (Step ps 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 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)   +++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% pErrors     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++class state `Stores`  errors where+  getErrors    ::  state   -> (errors, state)++class  p `AsksFor` errors where+  pErrors :: p errors+  pEnd    :: p errors++instance (Eof state, Stores state errors) =>  AsksFor (P_h state) errors where+  pErrors = P_h (\ k inp -> let (errs, inp') = getErrors inp+                            in k errs inp')+  pEnd    = P_h (\ 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+                )++instance (Eof state, Stores state errors) => AsksFor (P_f state) errors where+  pErrors = P_f (\ k   inp -> let (errs, inp') = getErrors inp+                              in push errs (k inp'))+  pEnd    = P_f (\ 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+                )++instance  (state `Stores` errors, Eof state) => AsksFor (P_m state)  errors where+  pErrors   = P_m  (pErrors,  pErrors)+  pEnd      = P_m  (pEnd,     pEnd)++{-+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Microsteps  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+++class MicroStep result where+  microstep :: result a -> result a++instance MicroStep Steps where+   microstep steps = Micro steps++class Micro p where+  micro :: p a -> p a++instance  Micro (P_f  st) where+  micro (P_f p) = P_f (\k st -> microstep ( p k st ) )+-}++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% State Change          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++class Switch p where+  pSwitch :: (st1 -> (st2, st2 -> st1)) -> p st2 a -> p st1 a++instance Switch P_h where+  pSwitch split (P_h p) = P_h  (\ k st1 ->  let (st2, back) = split st1+                                            in p (\ a st2' -> k a (back st2')) st2)++instance Switch P_f where+  pSwitch split (P_f p) = P_f  (\k st1 ->  let (st2, back) = split st1+                                           in p (\st2' -> k (back st2')) st2)++instance Switch P_m where+  pSwitch split (P_m (p, q)) = P_m (pSwitch split p, pSwitch split q)++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Recognisers           %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+type family State p :: *++newtype  R st a  = R (forall r . (st -> Steps   r) -> st -> Steps r)+unR (R p) = p++instance Functor (R st) where+ fmap f  (R r)       =  R r++instance Applicative (R st) where+ R p  <*>  R q   =   R (p.q)  + pure    a       =   R (id)++instance Alternative (R st) where+ R p  <|>  R q   =   R (\ k inp  -> p k inp `best` q k inp)  + empty           =   R (\ k inp  -> noAlts)++instance  (Provides state symbol token) =>  Symbol (R  state) symbol token where+  pSym a =  R (\k inp ->  splitState a (\ v inp' -> k inp') inp) ++++type instance State (P_f st) = st+type instance State (P_h st) = st+type instance State (P_m st) = st++{-++class StateOf p st | p -> st++instance StateOf (P_h st) st+instance StateOf (P_h st) st+instance StateOf (P_h st) st+-}++class  Applicative p => ExtApplicative p where+  (<*)      ::  p  a            -> R (State p) b   ->   p  a+  (*>)      ::  R  (State p)  b -> p           a   ->   p  a+  (<$)      ::  a               -> R (State p) b   ->   p  a++instance ExtApplicative (P_h st)  where+  P_h p <* R r     = P_h ( p. (r.)) +  R   r *> P_h p   = P_h ( r .p   )+  f     <$  R r    = P_h ( r . ($f))++instance ExtApplicative (P_f st) where+  P_f p <* R r     = P_f (\ k st -> p (r k) st)+  R   r *> P_f p   = P_f (\ k st -> r (p k) st)+  f     <$  R r    = P_f (\ k st -> push f (r k st))++instance  (ExtApplicative (P_h  st), ExtApplicative (P_f  st))+          =>  ExtApplicative (P_m  st)  where+  P_m (hp, fp)  <*  r               = P_m  (hp <* r, fp <* r) +  r             *>  P_m (hq, fq)    = P_m  (r  *> hq , r *> fq)+  f             <$  r               = P_m  (f  <$ r, f <$ r)       + +

@@ -0,0 +1,110 @@+module Text.ParserCombinators.UU.Derived where++import Text.ParserCombinators.UU.Core++infixl 4  <??>+infixl 2 `opt`++-- | Optionally recognize parser 'p'.+-- +-- If 'p' can be recognized, the return value of 'p' is used. Otherwise,+-- the value 'v' is used. Note that opt is greedy, if you do not want+-- this use @... <|> pure v@  instead. Furthermore, 'p' should not+-- recognise the empty string, since this would make your parser ambiguous!!+opt ::  (Parser p) => p a -> a -> p a+p `opt` v       =  p <<|> pure v  +                                                +(<$$>)    :: (Parser p) => (a -> b -> c) -> p b -> p (a -> c)+f <$$> p  =  flip f <$> p++(<??>) :: (Parser p) => p a -> p (a -> a) -> p a+p <??> q        = p <**> (q `opt` id)++-- | This can be used to parse 'x' surrounded by 'l' and 'r'.+-- +-- Example:+--+-- > pParens = pPacked pOParen pCParen+pPacked :: (Parser p) => R (State p) b1 -> R (State p) b2 -> p a -> p a+pPacked l r x   =   l *>  x <*   r++-- =======================================================================================+-- ===== Iterating ps ===============================================================+-- =======================================================================================+pFoldr    :: (Parser p) => (a -> a1 -> a1, a1) -> p a -> p a1+pFoldr_ng :: (Parser p) => (a -> a1 -> a1, a1) -> p a -> p 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+++pFoldr1    :: (Parser p) => (v -> b -> b, b) -> p v -> p b+pFoldr1_ng :: (Parser p) => (v -> b -> b, b) -> p v -> p b+pFoldr1        alg@(op,e)     p = op <$> p <*> pFoldr  alg p+pFoldr1_ng     alg@(op,e)     p = op <$> p <*> pFoldr_ng  alg p++pFoldrSep    :: (Parser p) => (v -> b -> b, b) -> R (State p) a -> p v -> p b+pFoldrSep_ng :: (Parser p) => (v -> b -> b, b) -> R (State p) a -> p v -> p 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++pFoldr1Sep    :: (Parser p) => (a -> b -> b, b) -> R (State p) a1 -> p a -> p b+pFoldr1Sep_ng :: (Parser p) => (a -> b -> b, b) -> R (State p) a1 -> p a -> p 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)++list_alg :: (a -> [a] -> [a], [a1])+list_alg = ((:), [])++pList    ::  (Parser p) =>  p a -> p [a]+pList_ng ::  (Parser p) =>  p a -> p [a]+pList           p = pFoldr        list_alg   p+pList_ng        p = pFoldr_ng     list_alg   p++pList1    ::  (Parser p) => p a -> p [a]+pList1_ng ::  (Parser p) => p a -> p [a]+pList1          p = pFoldr1       list_alg   p+pList1_ng       p = pFoldr1_ng    list_alg   p+++pListSep    :: (Parser p) => R (State p) a1 -> p a -> p [a]+pListSep_ng :: (Parser p) => R (State p) a1 -> p a -> p [a]+pListSep      s p = pFoldrSep     list_alg s p+pListSep_ng   s p = pFoldrSep_ng  list_alg s p++pList1Sep    :: (Parser p) => R (State p) a1 -> p a -> p [a]+pList1Sep_ng :: (Parser p) => R (State p) a1 -> p a -> p [a]+pList1Sep     s p = pFoldr1Sep    list_alg s p+pList1Sep_ng  s p = pFoldr1Sep_ng list_alg s p++pChainr    :: (Parser p) => p (c -> c -> c) -> p c -> p c+pChainr_ng :: (Parser p) => p (c -> c -> c) -> p c -> p c+pChainr    op x    =  r where r = x <??> (flip <$> op <*> r)+pChainr_ng op x    =  r where r = x <**> ((flip <$> op <*> r)  <|> pure id)++pChainl    :: (Parser p) => p (c -> c -> c) -> p c -> p c+pChainl_ng :: (Parser p) => p (c -> c -> c) -> p c -> p c+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) +                     where f x [] = x+                           f x (func:rest) = f (func x) rest++-- | Parses using any of the parsers in the list 'l'.++pAny :: (Alternative p) =>(a -> p a1) -> [a] -> p a1+pAny  f l =  foldr (<|>) empty (map f l)++-- | Parses any of the symbols in 'l'.+pAnySym :: (Alternative p, Symbol p s s) =>[s] -> p s+pAnySym = pAny pSym ++pToken :: (Applicative p, Symbol p s s) => [s] -> p [s]+pToken []     = pure []+pToken (a:as) = (:) <$> pSym a <*> pToken as++pAnyToken :: (Parser p, Symbol p s s) => [[s]] -> p [s]+pAnyToken = pAny pToken+

@@ -10,10 +10,7 @@ module Text.ParserCombinators.UU.Examples where import Char import Text.ParserCombinators.UU.Parsing-import Text.ParserCombinators.UU.BasicInstances-import Control.Applicative hiding ((<$), (<*), (*>)) - type P b =  P_m (Str Char) b -> String -> (b, [Error Char Char Int])  test :: P b test p inp = parse ( (,) <$> p <*> pEnd) (listToStr inp)@@ -31,7 +28,7 @@ pExact 0 p = pReturn [] pExact n p = (:) <$> p <*> pExact (n-1) p -paz = pMany (pSym ('a', 'z'))+paz = pList (pSym ('a', 'z'))  paz' = pSym (\t -> 'a' <= t && t <= 'z', "a .. z", 'k') @@ -48,20 +45,8 @@           print (test paz' "m")           print (test paz' "") -infixl 3 `opt`-p `opt` v = p <|> pReturn v  --- parsing many things-pMany p  = (:) <$> p <*> pMany p <|> pReturn []-pMany1 p = (:) <$> p <*> pMany p-pChoice = foldr (<|>) pFail-pSeq (p : pp ) = (:) <$> p <*> pSeq pp -pSeq [ ] = pReturn [ ] -pListSep p s = pListSep1 p s `opt` []-pListSep1 p s = (:) <$> p <*> pSepTail p s-   where pSepTail p s = pMany (s *> p) - -- bracketing expressions pParens p = id <$ pSym '(' <*> p <* pSym ')' pBracks p = id <$ pSym '[' <*> p <* pSym ']'@@ -70,19 +55,18 @@ -- parsing numbers pDigit = pSym ('0', '9') pDigitAsInt = digit2Int <$> pDigit -pNatural = foldl (\a b -> a * 10 + b ) 0 <$> pMany1 pDigitAsInt+pNatural = foldl (\a b -> a * 10 + b ) 0 <$> pList1 pDigitAsInt digit2Int a =  ord a - ord '0'  -- parsing letters and identifiers pLower  = pSym ('a','z') pUpper  = pSym ('A','Z') pLetter = pUpper <|> pLower-pVarId  = (:) <$> pLower <*> pMany pIdChar-pConId  = (:) <$> pUpper <*> pMany pIdChar-pIdChar = pLower <|> pUpper <|> pDigit <|> pSymIn "='"-pSymIn s = pChoice $ map pSym s-pKey str = pSeq (map pSym str)+pVarId  = (:) <$> pLower <*> pList pIdChar+pConId  = (:) <$> pUpper <*> pList pIdChar+pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='" + -- running the parser; if complete input accepted return the result else fail with reporting unconsumed tokens run :: forall t. P_m (Str Char) t -> String -> t run p i = do let (a,b) = exec p i@@ -98,14 +82,10 @@  pOp (c, op) = op <$ pSym c -pChainl t op = applyall <$> t <*> pMany (flip <$> op <*> t)-applyall e [] = e-applyall e (f:fs) = applyall (f e) fs--expr = term `pChainl` (pOp ('+', (+)) <|> pOp ('-', (-)))-term = factor `pChainl` pOp ('*' , (*))-factor = getal <|> pSym '(' *> expr <* pSym ')'-getal = pNatural+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

@@ -1,407 +1,6 @@--{-# LANGUAGE  RankNTypes, -              GADTs,-              MultiParamTypeClasses,-              FunctionalDependencies, -              FlexibleInstances, -              FlexibleContexts, -              UndecidableInstances,-              NoMonomorphismRestriction#-}---module Text.ParserCombinators.UU.Parsing where-import Prelude hiding (fail)-import Control.Applicative  hiding ((<*), (*>), (<$), many, some, optional)-import Char-import Debug.Trace-import Maybe--infixl  4  <*, *>-infixl  4  <$--ap f a = f a ---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Classes     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--class (Applicative p, Alternative p) => Parser p where--pReturn  = pure-pFail    = empty--class  Symbol p  symbol token | symbol -> token where-  pSym  ::  symbol -> p token--type Strings = [String]--type Cost = Int-type Progress = Int--class  Provides state symbol token | state symbol -> token  where-       splitState   ::  symbol -> (token -> state  -> Steps a) -> state -> Steps a--class Eof state where-       eof          ::  state   -> Bool-       deleteAtEnd  ::  state   -> Maybe (Cost, state)--class  Parse p  where-       parse  ::   Eof state => p state a -> state -> a---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Steps      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--data  Steps   a  where-      Step   ::              Progress       ->  Steps a                                -> Steps   a-      Fail   ::              [String]       ->  [[String]  ->       (Int, Steps   a)]  -> Steps   a-      Apply  ::  forall b.   (b -> a)       ->  Steps   b                              -> Steps   a-      End_h  ::              ([a] , [a] -> Steps r)        ->  Steps   (a,r)           -> Steps   (a, r)-      End_f  ::              [Steps   a]   ->  Steps   a                               -> Steps   a--fail        =  Fail [] [const ((0, fail))]-noAlts      =  Fail [] []--eval :: Steps   a      ->  a-eval (Step  _    l)     =   eval l-eval (Fail   ss  ls  )  =   eval (getCheapest 3 [f ss | f <- ls]) -eval (Apply  f   l   )  =   f (eval l)-eval (End_f   _  _   )  =   error "dangling End_fconstructor"-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))  --norm ::  Steps a ->  Steps   a-norm     (Apply f (Step   p    l  ))   =   Step p (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)-norm     (Apply f (End_h  _    _  ))   =   error "Apply before End_h"-norm     steps                         =   steps--applyFail f  = map (\ g -> \ ex -> let (c, l) =  g ex in  (c, f l))--best :: Steps   a -> Steps   a -> Steps   a-x `best` y =   norm x `best'` norm y--best' :: Steps   b -> Steps   b -> Steps   b-Fail  sl  ll     `best'`  Fail  sr rr     =   Fail (sl ++ sr) (ll++rr)-Fail  _   _      `best'`  r               =   r-l                `best'`  Fail  _  _      =   l-Step  n   l      `best'`  Step  m  r-    | 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)-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 ---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% History     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%---- do not change into data !!-newtype  P_h    st  a =  P_h  (forall r . (a  -> st -> Steps r)  -> st -> Steps r)-unP_h (P_h p) = p--instance   Functor (P_h  state) where -  fmap f      (P_h p)  =  P_h  (\  k -> p (\a -> k (f a))) --instance   Applicative (P_h  state) where-  (P_h p) <*> (P_h q)  =  P_h  (\  k -> p (\ f -> q (\ a -> k (f a))))  -  pure a               =  P_h  (\  k -> k a)--instance   Alternative (P_h  state) where -  (P_h p) <|> (P_h q)  =  P_h  (\  k inp  -> p k inp `best` q k inp) -  empty                =  P_h  (\  k -> const noAlts) --instance  ( Provides state symbol token) => Symbol (P_h  state) symbol token where-  pSym a =  P_h (splitState a)--data Id a = Id a deriving Show--instance   Parse P_h  where-  parse (P_h p)-   =  fst . eval . p  (\ a rest -> if eof rest then push a fail else error "pEnd missing?") ---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Future      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%---- do not change into data !!-newtype  P_f st a  = P_f (forall r . (st -> Steps   r) -> st -> Steps   (a, r))-unP_f (P_f p) = p--instance  Functor (P_f st) where- fmap f p     =   pure f <*> p--instance Applicative (P_f st) where- P_f p  <*>  P_f q  =   P_f ( (apply .) . (p .q)) - pure a          =   P_f ((push a).)--instance Alternative (P_f st) where- P_f p  <|>  P_f q  =   P_f (\ k inp  -> p k inp `best` q k inp)  - empty              =   P_f (\ k inp  -> noAlts)---instance  (Provides state symbol token) =>  Symbol (P_f  state) symbol token where-  pSym a =  P_f (\ k inp-> splitState a (\ t inp' -> push t (k inp')) inp)--instance  Parse P_f  where-  parse (P_f p) =  fst . eval . p (\ rest -> if eof rest then fail else error "pEnd missing")---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Monads      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--infixr 1 >>>=-class GenMonad  m_1 m_2 where-   (>>>=) :: m_1 b -> ( b -> m_2  a) -> m_2 a--instance     Monad (P_h  state) -         =>  GenMonad (P_h  state) (P_h state) where-  (>>>=)  = (>>=) --  the monadic bind defined before--instance GenMonad (P_h  state) (P_f  state) where-  (P_h p)  >>>= pv2q -           = P_f (\ k st -> p (\ pv st -> unP_f (pv2q pv) k st) st)--newtype P_m state a = P_m (P_h  state a, P_f state a) -unP_m_h (P_m  (P_h h,  _    ))  =  h-unP_m_f (P_m  (_    ,  P_f f))  =  f--instance  (   Functor (P_h  st), Functor (P_f  st)) -          =>  Functor (P_m  st) where- fmap f  (P_m (hp, fp))  = P_m  (fmap f hp, fmap f fp)      --instance  (   Applicative (P_h  st), Applicative (P_f  st)) -          =>  Applicative (P_m  st) where- P_m (hp, fp)  <*> ~(P_m (hq, fq))    = P_m  (hp <*> hq, fp <*> fq)- pure a                               = P_m  (pure a, pure a)       --instance  (   Alternative (P_h  st), Alternative (P_f  st)) -          =>  Alternative (P_m  st) where - P_m (hp, fp)  <|> P_m (hq, fq)    = P_m  (hp <|> hq, fp <|> fq)- empty                             = P_m  (empty,         empty)       --instance  (Provides state symbol token)  => Symbol (P_m state) symbol token where-  pSym a =  P_m (pSym a, pSym a)--instance   Parse P_m  where-  parse (P_m (_, (P_f fp)))  -      =  fst . eval. fp (\ rest -> if eof rest  then fail else error "End_fmissing?") --instance Applicative (P_h state) => Monad (P_h state) where-  P_h p >>= a2q  = P_h ( \ k -> p (\ a -> unP_h (a2q a) k))-  return     = pure--instance Applicative (P_m st) => Monad (P_m st) where-     P_m  (P_h p, _)  >>=  a2q = -           P_m  (  P_h   (\k -> p (\ a -> unP_m_h (a2q a) k))-                ,  P_f   (\k -> p (\ a -> unP_m_f (a2q a) k))-                )-     return  = pure ---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Greedy      %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--best_gr :: Steps a -> Steps a -> Steps a--l@  (Step _ _)   `best_gr` _  = l-l                `best_gr` r  = l `best` r--class  Greedy p where -  (<<|>) :: p a -> p a -> p a--instance Greedy (P_h state)  where-  P_h p <<|> P_h q = P_h (\ k st  -> norm (p k st) `best_gr` norm (q k st))--instance Greedy (P_f state)  where-  P_f p <<|> P_f q = P_f (\ k st  -> norm (p k st) `best_gr` norm (q k st))--instance Greedy (P_m state) where-    P_m (hp, fp)  <<|> P_m (hq, fq) = P_m  (hp <<|> hq, fp <<|> fq) ----- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Ambiguous   %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--class Ambiguous p where- amb :: p a -> p [a]--instance Ambiguous (P_h state) where-  amb (P_h p) = P_h ( \k ->  removeEnd_h . p (\ a st' -> End_h ([a], \ as -> k as 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 (End_h  (as, k_st  ) r  )  =   k_st as `best` removeEnd_h r ---instance Ambiguous (P_f state) where-  amb (P_f p) = P_f (\k inp -> combinevalues . removeEnd_f $ p (\st -> End_f [k st] noAlts) inp)-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 (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--instance (Ambiguous (P_h state), Ambiguous (P_f state)) => Ambiguous (P_m state) where-  amb  (P_m (hp, fp))  = P_m (amb hp, amb fp)-       --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% getCheapest  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--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 -                                     then let new = (traverse n ll w c) -                                          in if new < c then (new, ll) else btf-                                     else btf -                               )   (maxBound, error "getCheapest") l---traverse :: Int -> Steps a -> Int -> Int -> Int-traverse 0 _                =  \ v c ->  v-traverse n (Step ps 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 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)   ----- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% pErrors     %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--class state `Stores`  errors where-  getErrors    ::  state   -> (errors, state)--class  p `AsksFor` errors where-  pErrors :: p errors-  pEnd    :: p errors--instance (Eof state, Stores state errors) =>  AsksFor (P_h state) errors where-  pErrors = P_h (\ k inp -> let (errs, inp') = getErrors inp-                            in k errs inp')-  pEnd    = P_h (\ 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-                )--instance (Eof state, Stores state errors) => AsksFor (P_f state) errors where-  pErrors = P_f (\ k   inp -> let (errs, inp') = getErrors inp-                              in push errs (k inp'))-  pEnd    = P_f (\ 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-                )--instance  (state `Stores` errors, Eof state) => AsksFor (P_m state)  errors where-  pErrors   = P_m  (pErrors,  pErrors)-  pEnd      = P_m  (pEnd,     pEnd)--{---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Microsteps  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%---class MicroStep result where-  microstep :: result a -> result a--instance MicroStep Steps where-   microstep steps = Micro steps--class Micro p where-  micro :: p a -> p a--instance  Micro (P_f  st) where-  micro (P_f p) = P_f (\k st -> microstep ( p k st ) )--}---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% State Change          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--class Switch p where-  pSwitch :: (st1 -> (st2, st2 -> st1)) -> p st2 a -> p st1 a--instance Switch P_h where-  pSwitch split (P_h p) = P_h  (\ k st1 ->  let (st2, back) = split st1-                                            in p (\ a st2' -> k a (back st2')) st2)--instance Switch P_f where-  pSwitch split (P_f p) = P_f  (\k st1 ->  let (st2, back) = split st1-                                           in p (\st2' -> k (back st2')) st2)--instance Switch P_m where-  pSwitch split (P_m (p, q)) = P_m (pSwitch split p, pSwitch split q)---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Recognisers           %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--newtype  R st a  = R (forall r . (st -> Steps   r) -> st -> Steps r)-unR (R p) = p--instance Functor (R st) where- fmap f  (R r)       =  R r--instance Applicative (R st) where- R p  <*>  R q   =   R (p.q)  - pure    a       =   R (id)--instance Alternative (R st) where- R p  <|>  R q   =   R (\ k inp  -> p k inp `best` q k inp)  - empty           =   R (\ k inp  -> noAlts)--instance  (Provides state symbol token) =>  Symbol (R  state) symbol token where-  pSym a =  R (\k inp ->  splitState a (\ v inp' -> k inp') inp) ---class  Applicative p => ExtApplicative p st | p -> st where-  (<*)      ::  p  a          -> R st b   ->   p  a-  (*>)      ::  R st b        -> p    a   ->   p  a-  (<$)      ::  a             -> R st b   ->   p  a--instance ExtApplicative (P_h st) st where-  P_h p <* R r     = P_h ( p. (r.)) -  R   r *> P_h p   = P_h ( r .p   )-  f     <$  R r    = P_h ( r . ($f))--instance ExtApplicative (P_f st) st where-  P_f p <* R r     = P_f (\ k st -> p (r k) st)-  R   r *> P_f p   = P_f (\ k st -> r (p k) st)-  f     <$  R r    = P_f (\ k st -> push f (r k st))--instance  (ExtApplicative (P_h  st) st, ExtApplicative (P_f  st) st )-          =>  ExtApplicative (P_m  st) st where- P_m (hp, fp)  <*  r               = P_m  (hp <* r, fp <* r) - r             *>  P_m (hq, fq)    = P_m  (r  *> hq , r *> fq)- f             <$  r               = P_m  (f  <$ r, f <$ r)       - -+module Text.ParserCombinators.UU.Parsing ( 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,5 +1,5 @@ Name:                uu-parsinglib-Version:             2.1.0+Version:             2.2.0 Build-Type:          Simple License:             LGPL Author:              Doaitse Swierstra@@ -9,9 +9,39 @@ Bug-reports:         mailto:doaitse@swierstra.net Synopsis:            New version of the Utrecht University parser combinator library         Cabal-Version:       >=1.2-Description:         New version of the Utrecht University parser combinator library, containing monadic, online, error correction, annotation free, applicative style parser combinators, now based on Control.Applicative+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+                     .+                     The file Text.ParserCombinators.UU.Examples contains a ready-made main function,+                     which can be called to see the error correction at work.+                     .+                     The library is based on ideas described in the paper:+                     .+                     * S.Doaitse Swierstra.+                     /Combinator Parsing: A Short Tutorial/.+                     Technical Report, Universiteit Utrecht+                     (<http://www.cs.uu.nl/research/techreps/repo/CS-2008/2008-044.pdf>).+                     .+                     This tutorial will also appear in LNCS Volume 5520, which contains the lecture notes from +                     the Lernet Summerschool.+                     .+                     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+                     .+                      Category:            Text.ParserCombinators Parsing Text  Library-     Build-Depends:     base, haskell98-     Exposed-modules:   Text.ParserCombinators.UU.Parsing Text.ParserCombinators.UU.BasicInstances Text.ParserCombinators.UU.Examples+     Build-Depends:     base > 2 && <= 4, haskell98+     Exposed-modules:   Text.ParserCombinators.UU.Parsing +                        Text.ParserCombinators.UU.Core  +                        Text.ParserCombinators.UU.BasicInstances+                        Text.ParserCombinators.UU.Derived +                        Text.ParserCombinators.UU.Examples