diff --git a/Text/ParserCombinators/UU/BasicInstances.hs b/Text/ParserCombinators/UU/BasicInstances.hs --- a/Text/ParserCombinators/UU/BasicInstances.hs +++ b/Text/ParserCombinators/UU/BasicInstances.hs @@ -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 diff --git a/Text/ParserCombinators/UU/Core.hs b/Text/ParserCombinators/UU/Core.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/UU/Core.hs @@ -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) + + diff --git a/Text/ParserCombinators/UU/Derived.hs b/Text/ParserCombinators/UU/Derived.hs new file mode 100644 --- /dev/null +++ b/Text/ParserCombinators/UU/Derived.hs @@ -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 + diff --git a/Text/ParserCombinators/UU/Examples.hs b/Text/ParserCombinators/UU/Examples.hs --- a/Text/ParserCombinators/UU/Examples.hs +++ b/Text/ParserCombinators/UU/Examples.hs @@ -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 diff --git a/Text/ParserCombinators/UU/Parsing.hs b/Text/ParserCombinators/UU/Parsing.hs --- a/Text/ParserCombinators/UU/Parsing.hs +++ b/Text/ParserCombinators/UU/Parsing.hs @@ -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 diff --git a/uu-parsinglib.cabal b/uu-parsinglib.cabal --- a/uu-parsinglib.cabal +++ b/uu-parsinglib.cabal @@ -1,5 +1,5 @@ Name: uu-parsinglib -Version: 2.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 + (). + . + 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