diff --git a/src/Text/ParserCombinators/UU/BasicInstances.hs b/src/Text/ParserCombinators/UU/BasicInstances.hs --- a/src/Text/ParserCombinators/UU/BasicInstances.hs +++ b/src/Text/ParserCombinators/UU/BasicInstances.hs @@ -54,7 +54,8 @@ instance (Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) (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 (show a) pos exp]) pos False)) + = show_attempt ("Try Predicate: " ++ msg ++ "\n") ( + let ins exp = (5, k a (Str tts (msgs ++ [Inserted (show a) pos exp]) pos False)) del exp = (5, splitState (p,msg, a) k (Str (tail tts) @@ -67,6 +68,7 @@ (Step 1 (k t (Str ts msgs (advance pos t) True))) else Fail [msg] (ins: if del_ok then [del] else []) [] -> Fail [msg] [ins] + ) instance (Ord a, Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) (a,a) a where splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low) @@ -92,11 +94,13 @@ instance (Show a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Munch a) [a] where splitState (Munch p x) k inp@(Str tts msgs pos del_ok) - = let (munched, rest) = span p tts + = show_attempt ("Try Munch: " ++ x ++ "\n") ( + let (munched, rest) = span p tts l = length munched in if l > 0 then show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") (Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok)))) - else show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") (k [] inp) + else show_munch ("Accepting munch: " ++ x ++ " as emtty munch " ++ show pos ++ "\n") (k [] inp) + ) pMunch :: (Provides st (Munch a) [a]) => (a -> Bool) -> P st [a] pMunch p = pSymExt Zero Nothing (Munch p "") -- the empty case is handled above @@ -109,13 +113,15 @@ splitState tok@(Token as cost) k (Str tts msgs pos del_ok) = let l = length as msg = show as - in case stripPrefix as tts of + in show_attempt ("Try Token: " ++ show as ++ "\n") ( + case stripPrefix as tts of Nothing -> let ins exp = (cost, k as (Str tts (msgs ++ [Inserted msg pos exp]) pos False)) del exp = (5, splitState tok k (Str (tail tts) (msgs ++ [Deleted (show(head tts)) pos exp]) (advance pos [(head tts)]) True )) in if null tts then Fail [msg] [ins] else Fail [msg] (ins: if del_ok then [del] else []) Just rest -> show_tokens ("Accepting token: " ++ show as ++"\n") (Step l (k as (Str rest msgs (advance pos as) True))) + ) pToken :: (Provides state (Token a) token) => [a] -> P state token pToken as = pTokenCost as 5 @@ -124,11 +130,13 @@ where length [] = Zero length (_:as) = Succ (length as) -show_tokens :: a -> b -> b -show_tokens m v = {- trace m -} v +show_tokens :: String -> b -> b +show_tokens m v = {- trace m -} v -show_munch :: a -> b -> b -show_munch m v = {- trace m -} v +show_munch :: String -> b -> b +show_munch m v = {- trace m -} v -show_symbol :: a -> b -> b -show_symbol m v = {- trace m -} v +show_symbol :: String -> b -> b +show_symbol m v = {- trace m -} v + +show_attempt m v = {- trace m -} v diff --git a/src/Text/ParserCombinators/UU/CHANGELOG.hs b/src/Text/ParserCombinators/UU/CHANGELOG.hs --- a/src/Text/ParserCombinators/UU/CHANGELOG.hs +++ b/src/Text/ParserCombinators/UU/CHANGELOG.hs @@ -1,4 +1,8 @@ -- | This module just contains the CHANGELOG +-- Version 2.5.6 +-- +-- * added a special version of \<|\> (called '<-|->') in @ExtAlternative@ which does not compare the length of the parsers; to be used in permutations +-- -- Version 2.5.5.2 -- -- * type signatures were added to make Haddock happy @@ -7,7 +11,7 @@ -- -- * type signatures were added to make the library GHC 7 ready. -- ----- Version 2.5.5 +-- Version 2.5.5 -- -- * preference is given to earlier accept steps in order to avoid infinite insertions in case of otherwise equivalent repair strategies -- diff --git a/src/Text/ParserCombinators/UU/Core.hs b/src/Text/ParserCombinators/UU/Core.hs --- a/src/Text/ParserCombinators/UU/Core.hs +++ b/src/Text/ParserCombinators/UU/Core.hs @@ -18,7 +18,7 @@ infix 2 -- should be the last element in a sequence of alternatives infixl 3 <<|> -- intended use p <<|> q <<|> r <|> x <|> y z - +infixl 3 <-|-> -- an alternative for <|> which does not compare the lengths, to be used in permutation parsers -- ** `Provides' @@ -43,8 +43,10 @@ -- ** An extension to @`Alternative`@ which indicates a biased choice -- | In order to be able to describe greedy parsers we introduce an extra operator, whch indicates a biased choice -class ExtAlternative p where - (<<|>) :: p a -> p a -> p a +class (Alternative p) => ExtAlternative p where + (<<|>) :: p a -> p a -> p a + (<-|->) :: p a -> p a -> p a + (<-|->) = (<|>) -- * The triples containg a history, a future parser and a recogniser: @`T`@ @@ -166,7 +168,7 @@ in let nnp = (if b then (nq `alt` np) else (np `alt` nq)) nep = if b then trace' "calling pe" pe else trace' "calling qe" qe in P (mkParser nnp nep) nnp rl nep - empty = P empty empty Infinite Nothing + empty = P empty empty Infinite Nothing -- the always failing parser! -- ** An alternative for the Alternative, which is greedy: @`<<|>`@ -- | `<<|>` is the greedy version of `<|>`. If its left hand side parser can make some progress that alternative is committed. Can be used to make parsers faster, and even @@ -189,6 +191,13 @@ (maybe np (\nqq -> maybe nq (\npp -> return( choose npp nqq)) np) nq) rl (pe <|> qe) -- due to the way Maybe is instance of Alternative the left hand operator gets priority + P ap np pl pe <-|-> P aq nq ql qe + = let Nothing `alt` q = q + p `alt` Nothing = p + Just p `alt` Just q = Just (p <|>q) + in let nnp = np `alt` nq + nep = pe <|> qe + in P (mkParser nnp nep) nnp pl nep -- ** Parsers can recognise single tokens: @`pSym`@ and @`pSymExt`@ -- Many parsing libraries do not make a distinction between the terminal symbols of the language recognised @@ -578,8 +587,8 @@ get_length :: P a b -> Nat get_length (P _ _ l _) = l -trace' :: a -> b -> b -trace' m v = {- trace m -} v +trace' :: String -> b -> b +trace' m v = {- trace m -} v diff --git a/src/Text/ParserCombinators/UU/Derived.hs b/src/Text/ParserCombinators/UU/Derived.hs --- a/src/Text/ParserCombinators/UU/Derived.hs +++ b/src/Text/ParserCombinators/UU/Derived.hs @@ -190,18 +190,26 @@ oneAlt (Many p, others) = (p, Many p : others) oneAlt (Opt p, others) = (p, others) +toParser' :: [ Freq (P st (d -> d)) ] -> P st (d -> d) +toParser' [] = pure id +toParser' alts = let palts = [(.) <$> p <*> toParser' ps | (p,ps) <- split alts id] + in if and (map canBeEmpty alts) + then foldr (<|>) (pure id) palts + else foldr1 (<|>) palts + toParser :: [ Freq (P st (d -> d)) ] -> P st d -> P st d toParser [] units = units toParser alts units = let palts = [p <*> toParser ps units | (p,ps) <- split alts id] in if and (map canBeEmpty alts) - then foldr (<|>) units palts - else foldr1 (<|>) palts + then foldr (<-|->) units palts + else foldr1 (<-|->) palts + toParserSep :: [Freq (P st (b -> b))] -> P st a -> P st b -> P st b toParserSep alts sep units = let palts = [p <*> toParser (map (fmap (sep *>)) ps) units | (p,ps) <- split alts id] in if and (map canBeEmpty alts) - then foldr (<|>) units palts - else foldr1 (<|>) palts + then foldr (<-|->) units palts + else foldr1 (<-|->) palts newtype MergeSpec p = MergeSpec p 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.5.5.2 +Version: 2.5.6 Build-Type: Simple License: MIT Copyright: S Doaitse Swierstra