uu-parsinglib 2.2.1 → 2.3.0
raw patch · 12 files changed
+661/−714 lines, 12 filessetup-changed
Files
- Setup.hs +0/−0
- Text/ParserCombinators/UU/BasicInstances.hs +0/−57
- Text/ParserCombinators/UU/Core.hs +0/−425
- Text/ParserCombinators/UU/Derived.hs +0/−110
- Text/ParserCombinators/UU/Examples.hs +0/−107
- Text/ParserCombinators/UU/Parsing.hs +0/−6
- src/Text/ParserCombinators/UU/BasicInstances.hs +63/−0
- src/Text/ParserCombinators/UU/Core.hs +344/−0
- src/Text/ParserCombinators/UU/Derived.hs +128/−0
- src/Text/ParserCombinators/UU/Examples.hs +105/−0
- src/Text/ParserCombinators/UU/Parsing.hs +6/−0
- uu-parsinglib.cabal +15/−9
Setup.hs view
− Text/ParserCombinators/UU/BasicInstances.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE RankNTypes, - GADTs,- MultiParamTypeClasses,- FunctionalDependencies, - FlexibleInstances, - FlexibleContexts, - UndecidableInstances,- NoMonomorphismRestriction#-}---- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Some Instances %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--module Text.ParserCombinators.UU.BasicInstances where-import Text.ParserCombinators.UU.Core--data Error t s pos = Inserted s pos Strings- | Deleted t pos Strings- | DeletedAtEnd t--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 ++ " expecting one of " ++ show expecting - show (Deleted t pos expecting) = "\nDeleted " ++ show t ++ " at position " ++ show pos ++ " expecting one of " ++ show expecting - show (DeletedAtEnd t) = "\nThe token " ++ show t ++ "was not consumed by the parsing process." -data Str t = Str { input :: [t]- , msgs :: [Error t t Int ]- , pos :: !Int- , deleteOk :: !Bool}--listToStr ls = Str ls [] 0 True--instance (Show a) => Provides (Str a) (a -> Bool, String, a) a where- splitState (p, msg, a) k (Str tts msgs pos ok) - = let ins exp = (5, k a (Str tts (msgs ++ [Inserted 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 ))- in case tts of- (t:ts) -> if p t - then Step 1 (k t (Str ts msgs (pos + 1) True))- else Fail [msg] (ins: if ok then [del] else [])- [] -> Fail [msg] [ins]--instance (Ord a, Show a) => Provides (Str a) (a,a) a where- splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low)--instance (Eq a, Show a) => Provides (Str a) a a where- splitState a = splitState ((==a), show a, a) --instance 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 _ = Nothing---instance Stores (Str a) [Error a a Int] where- getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok)
− Text/ParserCombinators/UU/Core.hs
@@ -1,425 +0,0 @@--{-# 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) - -
− Text/ParserCombinators/UU/Derived.hs
@@ -1,110 +0,0 @@-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-
− Text/ParserCombinators/UU/Examples.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE RankNTypes, - GADTs,- MultiParamTypeClasses,- FunctionalDependencies, - FlexibleInstances, - FlexibleContexts, - UndecidableInstances,- NoMonomorphismRestriction#-}--module Text.ParserCombinators.UU.Examples where-import Char-import Text.ParserCombinators.UU.Parsing--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)--lift a = [a]--pa, pb, paz :: P_m (Str Char) [Char] -pa = lift <$> pSym 'a'-pb = lift <$> pSym 'b'-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--paz = pList (pSym ('a', 'z'))--paz' = pSym (\t -> 'a' <= t && t <= 'z', "a .. z", 'k')----- s = pSym 'x' <|> (\ _ x _ -> x) <$> pSym '(' <*> s <*> pSym ')'-x = pa <|> (pSym '(' *> pa <* pSym ')')-y = pb <|> pSym '(' *> x <* pSym ')'---- test_s = run s "x"--- test_t = run t "x"--s = pSym 'x' <|> (\ _ x _ -> x) <$> pSym '(' <*> s <*> pSym ')'-t = pSym 'x' <|> (pSym '(' *> t <* pSym ')')-t1 = pSym 'x' <|> pSym '(' *> t --main :: IO ()-main = do print (test t1 "((a))")- 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' "")------ bracketing expressions-pParens p = id <$ pSym '(' <*> p <* pSym ')'-pBracks p = id <$ pSym '[' <*> p <* pSym ']'-pCurlys p = id <$ pSym '{' <*> p <* pSym '}'---- parsing numbers-pDigit = pSym ('0', '9')-pDigitAsInt = digit2Int <$> pDigit -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 <*> 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- if null b then a else error (show b)--exec :: P_m (Str Char) b -> String -> (b, [Error Char Char Int])-exec p inp = parse ( (,) <$> p <*> pEnd) (listToStr inp)----- Testing-pTest_MS :: P_m (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)
− Text/ParserCombinators/UU/Parsing.hs
@@ -1,6 +0,0 @@-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
+ src/Text/ParserCombinators/UU/BasicInstances.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RankNTypes, + GADTs,+ MultiParamTypeClasses,+ FunctionalDependencies, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances,+ NoMonomorphismRestriction#-}++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Some Instances %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++module Text.ParserCombinators.UU.BasicInstances where+import Text.ParserCombinators.UU.Core++data Error t s pos = Inserted s pos Strings+ | Deleted t pos Strings+ | DeletedAtEnd t++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." +++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 ]+ , pos :: !Int+ , deleteOk :: !Bool}++listToStr ls = Str ls [] 0 True++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))+ del exp = (5, splitState (p,msg, a) + k+ (Str (tail tts) (msgs ++ [Deleted (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))+ else Fail [msg] (ins: if del_ok then [del] else [])+ [] -> Fail [msg] [ins]++instance (Ord a, Show a) => Provides (Str a) (a,a) a where+ splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low)++instance (Eq a, Show a) => Provides (Str a) a a where+ splitState a = splitState ((==a), show a, a) ++instance 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 _ = Nothing+++instance Stores (Str a) [Error a a Int] where+ getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok)
+ src/Text/ParserCombinators/UU/Core.hs view
@@ -0,0 +1,344 @@+-- | 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,+ MultiParamTypeClasses,+ FunctionalDependencies, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances,+ NoMonomorphismRestriction,+ ImpredicativeTypes #-}+++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 <$+-}+-- * 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 <$++-- ** `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.++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.++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.++-- ** `Provides'++class Provides state symbol token | state symbol -> token where+ splitState :: symbol -> (token -> state -> Steps a) -> state -> Steps a++-- ** `Eof'++class Eof state where+ 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`.+--+-- [@`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`+--+-- The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report.++type Cost = Int+type Progress = Int++data Steps a where+ Step :: Progress -> Steps a -> Steps a+ Apply :: forall b. (b -> a) -> Steps b -> Steps a++ Fail :: Strings -> [Strings -> (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++failAlways = Fail [] [const (0, failAlways)]+noAlts = Fail [] []++eval :: Steps a -> a+eval (Step _ l) = eval l+eval (Fail ss ls ) = 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)) ++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 ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% 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 + 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 _ 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) +++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Parsers %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++-- do not change into data, or be prepared to add ~ at subtle places !!+newtype 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+ ) +unP (P p) = p++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 (\ v inp' -> k inp') inp+ )++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 ++-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% Greedy %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++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 (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 (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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++class state `Stores` errors | state -> errors where+ getErrors :: state -> (errors, state)++pErrors :: Stores st errors => P st errors+pEnd :: (Stores st errors, Eof st) => P st errors++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'+ )++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+ )++{-+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%% 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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%++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]
+ src/Text/ParserCombinators/UU/Derived.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE RankNTypes, + GADTs,+ MultiParamTypeClasses,+ FunctionalDependencies, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances,+ NoMonomorphismRestriction,+ ImpredicativeTypes #-}++module Text.ParserCombinators.UU.Derived where+import Text.ParserCombinators.UU.Core++pReturn = pure+pFail = empty++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 :: P st a -> a -> P st a+p `opt` v = p <<|> pure v ++pMaybe :: P st a -> P st (Maybe a)+pMaybe p = Just <$> p `opt` Nothing ++pEither p q = Left <$> p <|> Right <$> q+ +(<$$>) :: (a -> b -> c) -> P st b -> P st (a -> c)+f <$$> p = flip f <$> p++(<??>) :: P st a -> P st (a -> a) -> P st 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 :: P st b1 -> P st b2 -> P st a -> P st a+pPacked l r x = l *> x <* r++-- =======================================================================================+-- ===== Iterating ps ===============================================================+-- =======================================================================================+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+++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++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++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)++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++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+++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++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++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)++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) + 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 :: (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+
+ src/Text/ParserCombinators/UU/Examples.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RankNTypes, + GADTs,+ MultiParamTypeClasses,+ FunctionalDependencies, + FlexibleInstances, + FlexibleContexts, + UndecidableInstances,+ NoMonomorphismRestriction#-}++module Text.ParserCombinators.UU.Examples where+import Char+import Text.ParserCombinators.UU.Parsing++type Pars a = P (Str Char) a +test :: Pars a -> String -> (a, [Error Char Char Int]) +test p inp = parse ( (,) <$> p <*> pEnd) (listToStr inp)++lift a = [a]++pa, pb, paz ::Pars [Char] +pa = lift <$> pSym 'a'+pb = lift <$> pSym 'b'+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++paz = pList (pSym ('a', 'z'))++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 parseBoth "(123;456;789)")++++-- bracketing expressions+pParens p = pSym '(' *> p <* pSym ')'+pBracks p = pSym '[' *> p <* pSym ']'+pCurlys p = pSym '{' *> p <* pSym '}'++-- parsing numbers+pDigit = pSym ('0', '9')+pDigitAsInt = digit2Int <$> pDigit +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 <*> pList pIdChar+pConId = (:) <$> pUpper <*> pList pIdChar+pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"++-- parsing two alternatives and returning both rsults+pAscii = pSym ('\000', '\254')+pIntList ::Pars [Int] +pIntList = pParens ((pSym ';') `pListSep` (read <$> pList (pSym ('0', '9'))))+parseIntString :: Pars 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)++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)
+ src/Text/ParserCombinators/UU/Parsing.hs view
@@ -0,0 +1,6 @@+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
uu-parsinglib.cabal view
@@ -1,5 +1,5 @@ Name: uu-parsinglib-Version: 2.2.1+Version: 2.3.0 Build-Type: Simple License: LGPL Author: Doaitse Swierstra@@ -35,14 +35,20 @@ . * contain a module with many list-based derived combinators .- * Version 2.2.1: bug fix: pattern matching too strict; ~ added-+ Versions above 2.3+ . contain some form of abstract interpretation from the old uulib versions of these combinators+ . are closer to Haskell98, since they do not make use of type families anymore+ . note that the basic parser interface will probably not change 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: Text.ParserCombinators Parsing Text Library- 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+ hs-source-dirs: src++ 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