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 @@ -44,7 +44,7 @@ import Text.ParserCombinators.UU.Core import Data.Maybe import Data.Word -import Debug.Trace +-- import Debug.Trace import qualified Data.ListLike as LL -- * `Error` @@ -142,7 +142,7 @@ -- and the second parameter how to proceed in case an element recognised by this parser is absent, -- and parsing may proceed by pretending such an element was present in the input anayway. pSatisfy :: forall loc state a .((Show a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> (Insertion a) -> P (Str a state loc) a) -pSatisfy p (Insertion msg a cost) = pSymExt splitState (Succ (Zero Infinite)) Nothing +pSatisfy p (Insertion msg a cost) = pSymExt splitState (Succ (Zero)) Nothing where splitState :: forall r. ((a -> (Str a state loc) -> Steps r) -> (Str a state loc) -> Steps r) splitState k (Str tts msgs pos del_ok) = show_attempt ("Try Predicate: " ++ msg ++ " at position " ++ show pos ++ "\n") ( @@ -179,7 +179,7 @@ -- | `pMunchL` recognises the longest prefix of the input for which the passed predicate holds. The message parameter is used when tracing has been switched on. pMunchL :: forall loc state a .((Show a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> String -> P (Str a state loc) [a]) -pMunchL p msg = pSymExt splitState (Zero Infinite) Nothing +pMunchL p msg = pSymExt splitState Zero Nothing where splitState :: forall r. (([a] -> (Str a state loc) -> Steps r) -> (Str a state loc) -> Steps r) splitState k inp@(Str tts msgs pos del_ok) = show_attempt ("Try Munch: " ++ msg ++ "\n") ( @@ -202,7 +202,7 @@ else pSymExt splitState (nat_length as) Nothing where tas :: state tas = LL.fromList as - nat_length [] = Zero Infinite + nat_length [] = Zero nat_length (_:as) = Succ (nat_length as) l = length as msg = show as @@ -224,7 +224,7 @@ ) pToken :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> P (Str a state loc) [a]) -pToken as = pTokenCost as 5 +pToken as = pTokenCost as 10 {-# INLINE show_tokens #-} 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.8.2 +-- +-- Change in the internal Steps data type in order to get correct behaviour when-- inserting at end of file +-- -- -- Version 2.7.4.1 -- 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 @@ -3,7 +3,8 @@ MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, - KindSignatures #-} + KindSignatures, + CPP #-} -- | The module `Core` contains the basic functionality of the parser library. -- It defines the types and implementations of the elementary parsers and recognisers involved. @@ -53,8 +54,12 @@ import Control.Applicative import Control.Monad import Data.Char -import Debug.Trace -import Prelude hiding ((.)) +-- import Debug.Trace +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 +import Prelude hiding ((.), traverse) +#else + import Prelude hiding ((.)) +#endif import Data.Maybe f . g = \x -> f ( g x) @@ -181,7 +186,7 @@ getOneP :: P a b -> Maybe (P a b) -- getOneP (P _ (Just _) (Zero Unspecified) _ ) = error "The element is a special parser which cannot be combined" getOneP (P _ Nothing _ l) = Nothing -getOneP (P _ onep ep l) = Just( mkParser onep Nothing (getLength l)) +getOneP (P _ onep ep l) = Just( mkParser onep Nothing l) -- | `getZeroP` retrieves the possibly empty part from a descriptor. getZeroP :: P t a -> Maybe a @@ -192,7 +197,7 @@ mkParser np ne l = P (mkParser' np ne) np ne l where mkParser' np@(Just nt) ne@Nothing = nt mkParser' np@Nothing ne@(Just a) = pure a - mkParser' np@(Just nt) ne@(Just a) = nt <|> pure a + mkParser' np@(Just nt) ne@(Just a) = pure a <|> nt mkParser' np@(Nothing) ne@(Nothing) = empty -- ! `combine` creates the non-empty parser @@ -200,9 +205,10 @@ -> (t1 -> t -> f a) -> (t2 -> t3 -> f a) -> Maybe (f a) combine Nothing Nothing _ _ _ _ = Nothing -- this Parser always fails combine (Just p) Nothing aq _ op1 op2 = Just (p `op1` aq) -combine (Just p) (Just v) aq nq op1 op2 = case nq of - Just nnq -> Just (p `op1` aq <|> v `op2` nnq) - Nothing -> Just (p `op1` aq ) -- rhs contribution is just from empty alt +combine (Just p) (Just v) aq nq op1 op2 = Just (case nq of + Just nnq -> p `op1` aq <|> v `op2` nnq + Nothing -> p `op1` aq -- rhs contribution is just from empty alt + ) combine Nothing (Just v) _ nq _ op2 = case nq of Just nnq -> Just (v `op2` nnq) -- right hand side has non-empty part Nothing -> Nothing -- neither side has non-empty part @@ -212,25 +218,29 @@ f <$ (P ap np me l) = P (f <$ ap) (fmap (f <$) np) (f <$ me) l instance Applicative (P state) where - P ap np pe pl <*> ~(P aq nq qe ql) = trace' "<*>" (mkParser (combine np pe aq nq (<*>) (<$>)) (pe <*> qe) (nat_add pl ql)) - P ap np pe pl <* ~(P aq nq qe ql) = trace' "<* " (mkParser (combine np pe aq nq (<*) (<$)) (pe <* qe ) (nat_add pl ql)) - P ap np pe pl *> ~(P aq nq qe ql) = trace' " *>" (mkParser (combine np pe aq nq (*>) (flip const)) (pe *> qe ) (nat_add pl ql)) - pure a = trace' "pure" (mkParser Nothing (Just a ) (Zero Infinite)) + P ap np pe pl <*> ~(P aq nq qe ql) = trace'' "<*>" (mkParser (combine np pe aq nq (<*>) (<$>)) (pe <*> qe) (nat_add pl ql)) + P ap np pe pl <* ~(P aq nq qe ql) = trace'' "<* " (mkParser (combine np pe aq nq (<*) (<$)) (pe <* qe ) (nat_add pl ql)) + P ap np pe pl *> ~(P aq nq qe ql) = trace'' " *>" (mkParser (combine np pe aq nq (*>) (flip const)) (pe *> qe ) (nat_add pl ql)) + pure a = trace'' "pure" (mkParser Nothing (Just a) Zero) instance Alternative (P state) where - P ap np pe pl <|> P aq nq qe ql - = let pl' = maybe pl (const (Zero pl)) pe - ql' = maybe ql (const (Zero ql)) qe - (rl, b) = trace' "calling natMin from <|>" (nat_min pl' ql' 0) + (P ap np pe pl) <|> (P aq nq qe ql) + = let pl' = maybe pl (const Zero) pe + ql' = maybe ql (const Zero) qe + (rl', b) = trace' "calling natMin from <|>" (nat_min pl' ql' 0) + (rl, _) = nat_min pl ql 0 Nothing `alt` q = q p `alt` Nothing = p - Just p `alt` Just q = Just (p <|>q) + Just p `alt` Just q = Just (p <|> q) in mkParser ((if b then id else flip) alt np nq) (pe <|> qe) rl empty = mkParser empty empty Infinite instance ExtAlternative (P st) where - P ap np pe pl <<|> P aq nq qe ql - = let (rl, b) = nat_min pl ql 0 + ~(P ap np pe pl) <<|> ~(P aq nq qe ql) + = let pl' = maybe pl (const Zero) pe + ql' = maybe ql (const Zero) qe + (rl', b) = nat_min pl' ql' 0 + (rl, _) = nat_min pl ql 0 bestx :: Steps a -> Steps a -> Steps a bestx = (if b then id else flip) best choose:: T st a -> T st a -> T st a @@ -253,10 +263,10 @@ ( \ k inp -> replaceExpected (norm ( pf k inp))) ( \ k inp -> replaceExpected (norm ( pr k inp)))) in mkParser nnp pe pl - must_be_non_empty msg p@(P _ _ _ (Zero _)) _ - = error ("The combinator " ++ msg ++ " requires that it's argument cannot recognise the empty string\n") + must_be_non_empty msg p@(P _ _ (Just _) _) _ + = error ("The combinator " ++ msg ++ " requires that its argument cannot recognise the empty string\n") must_be_non_empty _ _ q = q - must_be_non_empties msg (P _ _ _ (Zero _)) (P _ _ _ (Zero _)) _ + must_be_non_empties msg (P _ _ (Just _) _) (P _ _ (Just _) _) _ = error ("The combinator " ++ msg ++ " requires that not both arguments can recognise the empty string\n") must_be_non_empties _ _ _ q = q @@ -327,21 +337,21 @@ pErrors = let nnp = Just (T ( \ 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' )) - in mkParser nnp Nothing (Zero Infinite) + in mkParser nnp Nothing Zero -- | `pPos` returns the current input position. pPos :: HasPosition st pos => P st pos pPos = let nnp = Just ( T ( \ k inp -> let pos = getPos inp in k pos inp ) ( \ k inp -> let pos = getPos inp in push pos (k inp)) ( \ k inp -> k inp )) - in mkParser nnp Nothing (Zero Infinite) + in mkParser nnp Nothing Zero -- | `pState` returns the current input state pState :: P st st pState = let nnp = Just ( T ( \ k inp -> k inp inp) ( \ k inp -> push inp (k inp)) ($)) - in mkParser nnp Nothing (Zero Infinite) + in mkParser nnp Nothing Zero -- | The function `pEnd` should be called at the end of the parsing process. It deletes any unconsumed input, turning it into error messages. @@ -361,7 +371,7 @@ in (k finalstate) Just (i, inp') -> Fail [] [const (i, deleterest inp')] in deleterest inp)) - in mkParser nnp Nothing (Zero Infinite) + in mkParser nnp Nothing Zero -- | @`pSwitch`@ takes the current state and modifies it to a different type of state to which its argument parser is applied. -- The second component of the result is a function which converts the remaining state of this parser back into a value of the original type. @@ -382,16 +392,16 @@ -- | The function @`parse`@ shows the prototypical way of running a parser on -- some specific input. --- By default we use the future parser, since this gives us access to partal +-- By default we use the future parser, since this gives us access to partial -- result; future parsers are expected to run in less space. parse :: (Eof t) => P t a -> t -> a -parse (P (T _ pf _) _ _ _) = fst . eval . pf (\ rest -> if eof rest then Step 0 ( Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))) - else error "pEnd missing?") +parse (P (T _ pf _) _ _ _) state = fst . eval $ pf (\ rest -> if eof rest then Done () + else error "pEnd missing?") state -- | The function @`parse_h`@ behaves like @`parse`@ but using the history -- parser. This parser does not give online results, but might run faster. parse_h :: (Eof t) => P t a -> t -> a -parse_h (P (T ph _ _) _ _ _) = fst . eval . ph (\ a rest -> if eof rest then push a (Step 0 (Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))) ) - else error "pEnd missing?") +parse_h (P (T ph _ _) _ _ _) state = eval $ ph (\ a rest -> if eof rest then Done a + else error "pEnd missing?") state -- | The data type `Steps` is the core data type around which the parsers are constructed. -- It describes a tree structure of streams containing (in an interleaved way) both the online result of the parsing process, @@ -418,10 +428,20 @@ Step :: Progress -> Steps a -> Steps a Apply :: forall a b. (b -> a) -> Steps b -> Steps a Fail :: Strings -> [Strings -> (Cost , Steps a)] -> Steps a - Micro :: Int -> Steps a -> Steps a + Micro :: Int -> Steps a -> Steps a + Done :: a -> Steps a End_h :: ([a] , [a] -> Steps r) -> Steps (a,r) -> Steps (a, r) End_f :: [Steps a] -> Steps a -> Steps a +instance Show (Steps a) where + show (Step _ _) = "Step" + show (Apply _ _) = "Apply" + show (Fail _ _) = "Fail" + show (Micro _ _) = "Micro" + show (Done _) = "Done" + show (End_h _ _ ) = "End_h" + show (End_f _ _ ) = "End_f" + type Cost = Int type Progress = Int type Strings = [String] @@ -435,20 +455,13 @@ apply2fst :: (b -> a) -> Steps (b, r) -> Steps (a, r) apply2fst f = Apply (\ br -> let (b, r) = br in (f b, r)) -{- -succeedAlways :: Steps a -succeedAlways = let steps = Step 0 steps in steps - -failAlways :: Steps a -failAlways = Fail [] [const (0, failAlways)] --} - noAlts :: Steps a noAlts = Fail [] [] has_success :: Steps t -> Bool has_success (Step _ _) = True -has_success _ = False +has_success (Done _) = True +has_success _ = False -- | @`eval`@ removes the progress information from a sequence of steps, -- and constructs the value embedded in it. @@ -464,6 +477,7 @@ eval (Apply f l ) = f (eval l) eval (End_f _ _ ) = error "dangling End_f constructor" eval (End_h _ _ ) = error "dangling End_h constructor" +eval (Done a ) = a -- | `norm` makes sure that the head of the sequence contains progress information. -- It does so by pushing information about the result (i.e. the `Apply` steps) backwards. @@ -475,6 +489,7 @@ 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 (Apply f (Done a )) = Done (f a) norm steps = steps applyFail :: (c -> d) -> [a -> (b, c)] -> [a -> (b, d)] @@ -485,6 +500,9 @@ x `best` y = norm x `best'` norm y best' :: Steps b -> Steps b -> Steps b +(Done _) `best'` (Done _) = error "ambiguous parsers" +l@(Done _) `best'` r = l +l `best'` r@(Done _) = 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) @@ -504,7 +522,7 @@ | i == j = Micro i (l `best` r) | i < j = ls | i > j = rs -l `best'` r = error "missing alternative in best'" +l `best'` r = error ("missing alternative in best': " ++ show l ++ " " ++ show r) -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% getCheapest %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -531,6 +549,7 @@ ) traverse n (End_h ((a, lf)) r) v c = traverse n (lf a `best` removeEnd_h r) v c traverse n (End_f (l :_) r) v c = traverse n (l `best` r) v c +traverse n (Done _ ) v c = trace' ("traverse at Done" ++ show' 0 v c ++ " choosing" ++ show v ++ "\n") 0 show' :: (Show a, Show b, Show c) => a -> b -> c -> String show' n v c = "n: " ++ show n ++ " v: " ++ show v ++ " c: " ++ show c @@ -546,6 +565,7 @@ removeEnd_h (Apply f l ) = error "not in history parsers" removeEnd_h (Micro c l ) = Micro c (removeEnd_h l) removeEnd_h (End_h (as, k_st ) r ) = k_st as `best` removeEnd_h r +removeEnd_h (Done _) = error "spurious End_h at Done" removeEnd_f :: Steps r -> Steps [r] removeEnd_f (Fail m ls) = Fail m (applyFail removeEnd_f ls) @@ -556,32 +576,35 @@ removeEnd_f (End_f(s:ss) r) = Apply (:(map eval ss)) s `best` removeEnd_f r +removeEnd_f (Done _) = error "spurious End_f at Done" -- ** The type @`Nat`@ for describing the minimal number of tokens consumed -- | The data type @`Nat`@ is used to represent the minimal length of a parser. -- Care should be taken in order to not evaluate the right hand side of the binary function @`nat-add`@ more than necesssary. -data Nat = Zero Nat -- the length of the non-zero part of the parser is remembered) +data Nat = Zero | Succ Nat | Infinite | Unspecified | Hole deriving Show +{- -- | `getlength` retrieves the length of the non-empty part of a parser getLength :: Nat -> Nat getLength (Zero l) = l getLength l = l +-} addLength n (P t nep e l) = P t nep e (addLength' n l) addLength' :: Int -> Nat -> Nat -addLength' n (Zero _) = fromInt n +addLength' n Zero = fromInt n addLength' n (Succ m) = Succ (addLength' n m) addLength' n Infinite = Infinite addLength' n Unspecified = Unspecified addLength' n Hole = fromInt n -fromInt n = if n>= 0 then (n `times` Succ) (Zero undefined) else error "error: negative argument passed to addlength" +fromInt n = if n>= 0 then (n `times` Succ) Zero else error "error: negative argument passed to addlength" where times :: Int -> (Nat -> Nat) -> Nat -> Nat times 0 _ v = v times n f v = times (n-1) f (f v) @@ -592,11 +615,9 @@ nat_min :: Nat -> Nat -> Int -> ( Nat -- the actual minimum length , Bool -- whether alternatives should be swapped ) -nat_min (Zero l) (Zero r) n = trace' "Both Zero in nat_min\n" (Zero (trace' "Should not be called unless merging?" (fst(nat_min l r (n+1)))), False) -nat_min l rr@(Zero r) n = trace' "Right Zero in nat_min\n" (let (m,_) = nat_min l r (n+1) - in (Zero m, True)) -nat_min ll@(Zero l) r n = trace' "Left Zero in nat_min\n" (let (m,_) = nat_min l r (n+1) - in (Zero m, False)) +nat_min Zero Zero n = trace' "Both Zero in nat_min\n" (Zero , False) +nat_min l rr@Zero n = trace' "Right Zero in nat_min\n" (Zero , True) +nat_min ll@Zero r n = trace' "Left Zero in nat_min\n" (Zero, False) nat_min (Succ ll) (Succ rr) n = if n > 1000 then error "problem with comparing lengths" else trace' ("Succ in nat_min " ++ show n ++ "\n") (let (v, b) = nat_min ll rr (n+1) in (Succ v, b)) @@ -609,7 +630,7 @@ nat_add :: Nat -> Nat -> Nat -nat_add (Zero _) r = trace' "Zero in add\n" r +nat_add Zero r = trace' "Zero in add\n" r nat_add (Succ l) r = trace' "Succ in add\n" (Succ (nat_add l r)) nat_add Infinite _ = trace' "Infinite in add\n" Infinite nat_add Hole _ = Hole @@ -618,5 +639,10 @@ trace' :: String -> b -> b -trace' m v = {- trace m -} v --- trace' m v = trace m v +trace' m v = v +-- trace' m v = trace m v + +trace'' :: String -> b -> b +trace'' m v = v +--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 @@ -47,6 +47,16 @@ p q = must_be_non_empty "" q (p <**> (q `opt` id)) +-- | `<.>` functional composition of two parsers +-- +(<.>) :: IsParser p => p (b -> c) -> p (a -> b) -> p (a -> c) +f <.> g = (.) <$> f <*> g + +-- | `<..>` functional composition of two parsers with the arguments reversed +-- +(<..>) :: IsParser p => p (a -> b) -> p (b -> c) -> p (a -> c) +g <..> f = (.) <$> f <*> g + infixl 4 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.8.1.1 +Version: 2.9.0 Build-Type: Simple License: MIT Copyright: S Doaitse Swierstra @@ -9,11 +9,10 @@ Stability: stable, but evolving Homepage: http://www.cs.uu.nl/wiki/bin/view/HUT/ParserCombinators Bug-reports: mailto:doaitse@swierstra.net -Synopsis: Fast, online, error-correcting, monadic, applicative, merging, permuting, idiomatic parser combinators. +Synopsis: Fast, online, error-correcting, monadic, applicative, merging, permuting, interleaving, idiomatic parser combinators. Description: New version of the Utrecht University parser combinator library, which provides online, error correction, - annotation free, applicative style parser combinators. In addition to this we do provide a monadic and idomatic interface. - Parsers do analyse themselves to avoid commonly made errors. A recent addition was the combinator @`<||>`@ and - associates, which generalise merging and permuting parsers. + annotation free, applicative style parser combinators. In addition to this we provide a monadic and an idomatic interface. + Parsers do analyse themselves to avoid commonly made errors. . This version is based on the module "Data.Listlike", and as a result a great variety of input structures (@Strings@, @ByteStrings@, etc.) can be handled. @@ -40,7 +39,7 @@ Library hs-source-dirs: src - Build-Depends: base >= 4.2 && <5, time, ListLike >= 3.0.1, uu-interleaved >= 0.1.0 && < 0.2 + Build-Depends: base >= 4.2 && <5, time, ListLike >= 3.0.1, uu-interleaved >= 0.1.0 && < 0.3 Exposed-modules: Text.ParserCombinators.UU Text.ParserCombinators.UU.CHANGELOG