uu-parsinglib 2.5.6.1 → 2.7.0
raw patch · 13 files changed
+1535/−972 lines, 13 filesdep +ListLikedep +timedep −haskell98
Dependencies added: ListLike, time
Dependencies removed: haskell98
Files
- src/Text/ParserCombinators/UU.hs +16/−9
- src/Text/ParserCombinators/UU/BasicInstances.hs +173/−90
- src/Text/ParserCombinators/UU/CHANGELOG.hs +52/−3
- src/Text/ParserCombinators/UU/Core.hs +292/−288
- src/Text/ParserCombinators/UU/Demo/Examples.hs +271/−0
- src/Text/ParserCombinators/UU/Demo/MergeAndPermute.hs +132/−0
- src/Text/ParserCombinators/UU/Derived.hs +91/−183
- src/Text/ParserCombinators/UU/Examples.hs +0/−383
- src/Text/ParserCombinators/UU/Idioms.hs +55/−0
- src/Text/ParserCombinators/UU/MergeAndPermute.hs +123/−0
- src/Text/ParserCombinators/UU/README.hs +1/−1
- src/Text/ParserCombinators/UU/Utils.hs +309/−0
- uu-parsinglib.cabal +20/−15
src/Text/ParserCombinators/UU.hs view
@@ -1,28 +1,35 @@--- | The non-exported module "Text.ParserCombinators.UU.Examples" contains a list of examples of how to use the main functionality of this library which demonstrates:+-- | The non-exported modules in "Text.ParserCombinators.UU.Demo" contain a list of examples of how to use the main functionality of this library which demonstrates: -- -- * how to write basic parsers -- -- * how to to write ambiguous parsers ----- * how the error correction works+-- * how error correction works ----- * how to fine tune your parsers to get rid of ambiguities+-- * how to fine-tune your parsers to get rid of ambiguities -- -- * how to use the monadic interface ----- * what kind of error messages you can get if you write erroneous parsers+-- * what kind of error messages you can expect if you write erroneous parsers ----- * how to use the permutation/merging parsers+-- * how to use the permutating/merging parsers ----- * to see the parsers in action load the module "Text.ParserCombinators.UU.Examples" in @ghci@ and type @main@ or @demo_merge@, while looking at the corresponding code+-- * to see the parsers in action load the module "Text.ParserCombinators.UU.Demo.Examples" or "Text.ParserCombinators.UU.Demo.MergeAndPermute"in @ghci@ and type @show_demos@, while looking at the corresponding code -- module Text.ParserCombinators.UU ( module Text.ParserCombinators.UU.Core- , module Text.ParserCombinators.UU.BasicInstances , module Text.ParserCombinators.UU.Derived-) where+ , module Text.ParserCombinators.UU.MergeAndPermute+ , module Control.Applicative+ , module Control.Monad+ ) where import Text.ParserCombinators.UU.Core-import Text.ParserCombinators.UU.BasicInstances import Text.ParserCombinators.UU.Derived+import Text.ParserCombinators.UU.MergeAndPermute+import Control.Applicative+import Control.Monad+++
src/Text/ParserCombinators/UU/BasicInstances.hs view
@@ -6,137 +6,220 @@ FlexibleContexts, UndecidableInstances, NoMonomorphismRestriction,- TypeSynonymInstances #-}+ TypeSynonymInstances,+ ScopedTypeVariables #-} --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Some Instances %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%+-- | This module caontains basic instances for the class interface described in the "Text.ParserCombinators.UU.Core" module.+-- It demonstates how to use construct and maintain a state during parsing. In the state we store error messages, +-- positional information and the actual input that is being parsed.+-- Unless you have very specific wishes the module can be used as such. +-- Since we make use of the "Data.ListLike" interface a wide variety of input structures can be handled.+--+-- The main part of this module is made up from the various instances for the class `Provides` -module Text.ParserCombinators.UU.BasicInstances where+module Text.ParserCombinators.UU.BasicInstances(+-- * Data Types+ Error (..),+ Str (..),+ Insertion (..),+ LineCol (..),+ LineColPos (..),+-- * Types+ Parser,+ ParserTrafo,+-- * Classes+ IsLocationUpdatedBy,+-- * Functions+ createStr,+ show_expecting,+ pSatisfy,+ pRangeInsert,+ pRange,+ pSymInsert,+ pSym,+ pToken,+ pTokenCost,+ pMunch+) where import Text.ParserCombinators.UU.Core-import Data.List+import Data.Maybe+import Data.Word import Debug.Trace+import qualified Data.ListLike as LL -data Error pos = Inserted String pos Strings- | Deleted String pos Strings+-- * `Error`+-- |The data type `Error` describes the various kinds of errors which can be generated by the instances in this module+data Error pos = Inserted String pos Strings + -- ^ @String@ was inserted at @pos@-ition, where we expected @Strings@+ | Deleted String pos Strings+ -- ^ @String@ was deleted at @pos@-ition, where we expected @Strings@+ | Replaced String String pos Strings+ -- ^ for future use | DeletedAtEnd String+ -- ^ the unconsumed part of the input was deleted instance (Show pos) => Show (Error pos) where - show (Inserted s pos expecting) = "-- > Inserted " ++ s ++ " at position " ++ show pos ++ show_expecting expecting - show (Deleted t pos expecting) = "-- > Deleted " ++ t ++ " at position " ++ show pos ++ show_expecting expecting - show (DeletedAtEnd t) = "-- > The token " ++ t ++ " was not consumed by the parsing process."+ show (Inserted s pos expecting) = "-- Inserted " ++ s ++ show_expecting pos expecting + show (Deleted t pos expecting) = "-- Deleted " ++ t ++ show_expecting pos expecting+ show (Replaced old new pos expecting) = "-- Replaced " ++ old ++ " by "++ new ++ show_expecting pos expecting+ show (DeletedAtEnd t) = "-- The token " ++ t ++ " was not consumed by the parsing process." -show_errors :: (Show a) => [a] -> IO ()-show_errors = sequence_ . (map (putStrLn . show)) -show_expecting :: [String] -> String-show_expecting [a] = " expecting " ++ a-show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"-show_expecting [] = " expecting nothing" -data Str t loc = Str { input :: [t]- , msgs :: [Error loc ]- , pos :: loc- , deleteOk :: !Bool}+show_expecting :: Show pos => pos -> [String] -> String+show_expecting pos [a] = " at position " ++ show pos ++ " expecting " ++ a+show_expecting pos (a:as) = " at position " ++ show pos ++ + " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"+show_expecting pos [] = " expecting nothing" -listToStr :: [t] -> loc -> Str t loc-listToStr ls initloc = Str ls [] initloc True+-- * The Stream data type+-- | The data type `Str` holds the input data to be parsed, the current location, the error messages generated +-- and whether it is ok to delet elements from the input. Since an insert/delete action is +-- the same as a delete/insert action we try to avoid the first one. +-- So: no deletes after an insert. -type Parser a = P (Str Char (Int,Int)) a -instance IsLocationUpdatedBy (Int,Int) Char where- advance (line,pos) c = case c of- '\n' -> (line+1, 0) - '\t' -> (line , pos + 8 - (pos-1) `mod` 8)- _ -> (line , pos + 1)+data Str a s loc = Str { -- | the unconsumed part of the input+ input :: s, + -- | the accumulated error messages+ msgs :: [Error loc],+ -- | the current input position + pos :: loc, + -- | we want to avoid deletions after insertions+ deleteOk :: !Bool + } -instance IsLocationUpdatedBy (Int,Int) String where- advance = foldl advance +-- | A`Parser` is a parser that is prepared to accept "Data.Listlike" input; hence we can deal with @String@'s, @ByteString@'s, etc.+type Parser a = (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a -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) - = 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) - (msgs ++ [Deleted (show(head tts)) pos exp]) - (advance pos (head tts))- True ))- in case tts of- (t:ts) -> if p t - then show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n") - (Step 1 (k t (Str ts msgs (advance pos t) True)))- else Fail [msg] (ins: if del_ok then [del] else [])- [] -> Fail [msg] [ins]- )+-- | A @`ParserTrafo` a b@ maps a @`Parser` a@ onto a @`Parser` b@.+type ParserTrafo a b = (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a -> P (Str Char state loc) b -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)+-- | `createStr` initialises the input stream with the input data and the initial position. There are no error messages yet.+createStr :: LL.ListLike s a => loc -> s -> Str a s loc+createStr beginpos ls = Str ls [] beginpos True -instance (Eq a, Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) a a where- splitState a = splitState ((==a), show a, a) -instance Show a => Eof (Str a loc) where- eof (Str i _ _ _ ) = null i- deleteAtEnd (Str (i:ii) msgs pos ok ) = Just (5, Str ii (msgs ++ [DeletedAtEnd (show i)]) pos ok)- deleteAtEnd _ = Nothing+-- | The first parameter is the current position, and the second parameter the part which has been removed from the input.+instance IsLocationUpdatedBy Int Char where+ advance pos _ = pos + 1+ +instance IsLocationUpdatedBy Int Word8 where+ advance pos _ = pos + 1+ +data LineCol = LineCol !Int !Int deriving Show+instance IsLocationUpdatedBy LineCol Char where+ advance (LineCol line pos) c = case c of+ '\n' -> LineCol (line+1) 0+ '\t' -> LineCol line ( pos + 8 - (pos-1) `mod` 8)+ _ -> LineCol line (pos + 1) +data LineColPos = LineColPos !Int !Int !Int deriving Show+instance IsLocationUpdatedBy LineColPos Char where+ advance (LineColPos line pos abs) c = case c of+ '\n' -> LineColPos (line+1) 0 (abs + 1) + '\t' -> LineColPos line (pos + 8 - (pos-1) `mod` 8) (abs + 1)+ _ -> LineColPos line (pos + 1) (abs + 1) -instance Stores (Str a loc) (Error loc) where+instance IsLocationUpdatedBy loc a => IsLocationUpdatedBy loc [a] where+ advance = foldl advance ++instance (Show a, LL.ListLike s a) => Eof (Str a s loc) where+ eof (Str i _ _ _ ) = LL.null i+ deleteAtEnd (Str s msgs pos ok ) | LL.null s = Nothing+ | otherwise = Just (5, Str (LL.tail s) (msgs ++ [DeletedAtEnd (show (LL.head s))]) pos ok)+++instance StoresErrors (Str a s loc) (Error loc) where getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok) -instance HasPosition (Str a loc) loc where+instance HasPosition (Str a s loc) loc where getPos (Str inp msgs pos ok ) = pos --- pMunch+data Insertion a = Insertion String a Cost+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+ 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 ++ "\n") (+ let ins exp = (cost, k a (Str tts (msgs ++ [Inserted (show a) pos exp]) pos False))+ in if LL.null tts + then Fail [msg] [ins]+ else let t = LL.head tts+ ts = LL.tail tts+ del exp = (5, splitState k (Str ts (msgs ++ [Deleted (show t) pos exp]) (advance pos t) True ))+ in if p t+ then show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n") + (Step 1 (k t (Str ts msgs (advance pos t) True)))+ else Fail [msg] (ins: if del_ok then [del] else [])+ )+pRangeInsert :: (Ord a, Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => (a, a) -> Insertion a -> P (Str a state loc) a+pRangeInsert (low, high) = pSatisfy (\ t -> low <= t && t <= high) -data Munch a = Munch (a -> Bool) String+pRange lh@(low, high) = pRangeInsert lh (Insertion (show low ++ ".." ++ show high) low 5) -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)- = show_attempt ("Try Munch: " ++ x ++ "\n") (- let (munched, rest) = span p tts++pSymInsert :: (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a -> Insertion a -> P (Str a state loc) a+pSymInsert t = pSatisfy (==t) ++pSym :: (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a -> P (Str a state loc) a +pSym t = pSymInsert t (Insertion (show t) t 5)++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 (Succ (Zero Infinite)) 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") (+ let (fmunch, rest) = LL.span p tts+ munched = LL.toList fmunch l = length munched- in if l > 0 then show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") + in if l > 0 then show_munch ("Accepting munch: " ++ msg ++ " " ++ 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 ++ " as emtty munch " ++ show pos ++ "\n") (k [] inp)+ else show_munch ("Accepting munch: " ++ msg ++ " 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-pMunchL p l = pSymExt Zero Nothing (Munch p l) -- the empty case is handled above---data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token+pMunch p = pMunchL p "" -instance (Show a, Eq a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Token a) [a] where - splitState tok@(Token as cost) k (Str tts msgs pos del_ok)- = let l = length as+pTokenCost :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str a state loc) [a])+pTokenCost as cost = + if null as then error "Module: BasicInstances, function: pTokenCost; call with empty token"+ else pSymExt splitState (nat_length as) Nothing+ where tas :: state + tas = LL.fromList as+ nat_length [] = Zero Infinite+ nat_length (_:as) = Succ (nat_length as)+ l = length as msg = show as - 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+ 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 Token: " ++ show as ++ "\n") (+ if LL.isPrefixOf tas tts+ then show_tokens ("Accepting token: " ++ show as ++"\n") + (Step l (k as (Str (LL.drop l tts) msgs (advance pos as) True)))+ else let ins exp = (cost, k as (Str tts (msgs ++ [Inserted msg pos exp]) pos False))+ in if LL.null tts + then Fail [msg] [ins]+ else let t = LL.head tts+ ts = LL.tail tts+ del exp = (5, splitState k + (Str ts (msgs ++ [Deleted (show t) pos exp]) + (advance pos t) True))+ in Fail [msg] (ins: if del_ok then [del] else [])+ + ) pToken as = pTokenCost as 5-pTokenCost as c = if null as then error "call to pToken with empty token"- else pSymExt (length as) Nothing (Token as c)- where length [] = Zero- length (_:as) = Succ (length as) +{-# INLINE show_tokens #-}+ show_tokens :: String -> b -> b show_tokens m v = {- trace m -} v +{-# INLINE show_munch #-} show_munch :: String -> b -> b show_munch m v = {- trace m -} v +{-# INLINE show_symbol #-} show_symbol :: String -> b -> b show_symbol m v = {- trace m -} v +{-# INLINE show_attempt #-} show_attempt m v = {- trace m -} v
src/Text/ParserCombinators/UU/CHANGELOG.hs view
@@ -1,11 +1,59 @@ -- | This module just contains the CHANGELOG+--+-- Version 2.7.0+--+-- Improvement: change of error correction at end of @amb@ combinator, so lookahead is better taken into account+--+-- Relatively large change:+--+-- * Change to "Data.ListLike" inputs, so a general stream input structure is possible; hence we can now parse all instances of @ListLike@+--+-- * Simplified and generalised implementation of merging/permuting parsers; any kind of parsers can now be merged/permuted+--+-- * New class @IsParser@ was introduced which captures the basic properties of our parsers+--+-- * Inclusion of a module "Text.ParserCombinators.UU.Utils" containing common @Char@ based parsers+--+-- * Removal of the class @Provides@, and replaced by separate `pSym`, `pSatisfy` and `pRange`; +-- this may require some rwriting of existing parsers. Readbaility is supposed to improve from that. +-- Types become simpler. For an example see the module "Text.ParserCombinators.UU.Utils".+--+-- * Included a Demo directory, with a modules for demonstrating nromal parsers and one aimed at merging parsers+--+-- * added the module "Text.ParserCombinaors.UU.Idioms", which contains specialised version for the idiomatic notation; it infers the+-- sequental composition operators from the types of the operands; @String@-s and @Char@-s are not supposed to contribute to the result,+-- function parameters are lifted using `pure`, and normal parsers are composed with `<*>`.+--+-- * Many other small changes, mostly upwards compatible or invisible (code cleanup)+--+-- Version 2.6.1+--+-- * Changed the input to a @Stream@ interface to handle different kind of inputs like @String@, @Data.Text@ and @Data.ByteString@.+--+-- * To update old code to the new interface you should add+--+-- > import Text.ParserCombinators.UU.BasicInstances.String+--+-- in the file header and change+--+-- > listToStr inp (0,0)+--+-- to+--+-- > createStr inp+--+-- * To work with other inputs, import "Text.ParserCombinators.UU.BasicInstances.List", "Text.ParserCombinators.UU.BasicInstances.Text", +-- "Text.ParserCombinators.UU.BasicInstances.ByteString" or "Text.ParserCombinators.UU.BasicInstances.ByteString.Lazy".+--+-- -- Version 2.5.6.1 -- -- * replaced references to modules with references in the new library scheme -- -- 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+-- * 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 --@@ -25,7 +73,8 @@ -- -- Version 2.5.4.1 ----- * added a @pSem@ which makes it possible to tell how certain components of merged structures are to be combined before exposing all elements to the outer sem: +-- * added a @pSem@ which makes it possible to tell how certain components of merged structures+-- are to be combined before exposing all elements to the outer sem: -- -- > run ( (,) `pMerge` ( ((++) `pSem` (pMany pa <||> pMany pb)) <||> pOne pc)) "abcaaab" -- >@@ -157,5 +206,5 @@ module Text.ParserCombinators.UU.CHANGELOG () where -+dummy :: a dummy = undefined
src/Text/ParserCombinators/UU/Core.hs view
@@ -1,72 +1,161 @@ {-# LANGUAGE RankNTypes, GADTs, MultiParamTypeClasses,- FunctionalDependencies #-}+ FunctionalDependencies,+ FlexibleInstances #-}+-- | The module `Core` contains the basic functionality of the parser library.+-- It defines the types and implementations of the elementary parsers and recognisers involved. --- | The module `Core` contains the basic functionality of the parser library. --- It uses the breadth-first module to realise online generation of results, the error--- correction administration, dealing with ambigous grammars; it defines the types of the elementary parsers--- and recognisers involved.For typical use cases of the libray see the module @"Text.ParserCombinators.UU.Examples"@+module Text.ParserCombinators.UU.Core + ( -- * Classes+ IsParser,+ ExtAlternative (..),+-- Provides (..),+ Eof (..),+ IsLocationUpdatedBy (..),+ StoresErrors (..),+ HasPosition (..),+ -- * Types+ -- ** The parser descriptor+ P (),+ -- ** The progress information+ Steps (..),+ Cost,+ Progress,+ -- ** Auxiliary types+ Nat (..),+ Strings,+ -- * Functions+ -- ** Basic Parsers+ micro,+ amb,+ pErrors,+ pPos,+ pEnd,+ pSwitch,+ pSymExt,+-- pSym,+ -- ** Calling Parsers+ parse, parse_h,+ -- ** Acessing various components + getZeroP,+ getOneP,+ -- ** Evaluating the online result+ eval+ ) where -module Text.ParserCombinators.UU.Core ( module Text.ParserCombinators.UU.Core- , module Control.Applicative) where-import Control.Applicative hiding (many, some, optional)+import Control.Applicative+import Control.Monad import Data.Char import Debug.Trace import Data.Maybe +-- | In the class `IsParser` we assemble the basic properties we expect parsers to have. The class itself does not have any methods. +-- Most properties come directly from the standard +-- "Control.Applicative" module. The class `ExtAlternative` contains some extra methods we expect our parsers to have.+class (Alternative p, Applicative p, ExtAlternative p) => IsParser p -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+instance MonadPlus (P st) where+ mzero = empty+ mplus = (<|>) --- ** `Provides'+class (Alternative p) => ExtAlternative p where+ -- | `<<|>` is the greedy version of `<|>`. If its left hand side parser can+ -- make any progress that alternative is committed. Can be used to make+ -- parsers faster, and even get a complete Parsec equivalent behaviour, with+ -- all its (dis)advantages. Intended use @p \<\<\|> q \<\<\|> r \<\|> x \<\|> y \<?> "string"@. Use with care! + (<<|>) :: p a -> p a -> p a+ -- | The parsers build a list of symbols which are expected at a specific point. + -- This list is used to report errors.+ -- Quite often it is more informative to get e.g. the name of the non-terminal . + -- The `<?>` combinator replaces this list of symbols by the string argument. + (<?>) :: p a -> String -> p a+ -- | `doNotInterpret` makes a parser opaque for abstract interpretation; used when permuting parsers+ -- where we do not want to compare lengths+ doNotInterpret :: p a -> p a+ doNotInterpret = id+ -- | `must_be_non_empty` checks whether its second argument+ -- is a parser which can recognise the empty input. If so, an error message is+ -- given using the String parameter. If not, then the third argument is+ -- returned. This is useful in testing for illogical combinations. For its use see+ -- the module "Text.ParserCombinators.UU.Derived".+ must_be_non_empty :: String -> p a -> c -> c+ --+ -- | `must_be_non_empties` is similar to `must_be_non_empty`, but can be + -- used in situations where we recognise a sequence of elements separated by + -- other elements. This does not make sense if both parsers can recognise the + -- empty string. Your grammar is then highly ambiguous.+ must_be_non_empties :: String -> p a -> p b -> c -> c + -- | If 'p' can be recognized, the return value of 'p' is used. Otherwise,+ -- the value 'v' is used. Note that `opt` by default is greedy. If you do not want+ -- this use @...\<\|> pure v@ instead. Furthermore, 'p' should not+ -- recognise the empty string, since this would make the parser ambiguous!!+ opt :: p a -> a -> p a+ opt p v = must_be_non_empty "opt" p (p <<|> pure v) --- | The function `splitState` playes a crucial role in splitting up the state. The `symbol` parameter tells us what kind of thing, and even which value of that kind, is expected from the input.--- The state and and the symbol type together determine what kind of token has to be returned. Since the function is overloaded we do not have to invent --- all kind of different names for our elementary parsers.+infix 2 <?> +infixl 3 <<|> +infixl 2 `opt`++{-+-- | The function `splitState` playes a crucial role in splitting up the state. +-- The `symbol` parameter tells us what kind of thing, and even which value of that kind, is expected from the input.+-- The @state@ and and the @symbol@ type together determine what type of @token@ is to be returned. +-- Since the function is overloaded we do not have to invent all kind of different names for our elementary parsers.+-- This may be a bit confusing if you are not used to this. Error messages may be a bit harder to decipher.+-- The function takes as second parameter a continutation which is called with the +-- recognised piece of input (the @token@) and the remaining input of type @state@. class Provides state symbol token | state symbol -> token where splitState :: symbol -> (token -> state -> Steps a) -> state -> Steps a---- ** `Eof'+-} +-- | The class `Eof` contains a function `eof` which is used to check whether we have reached the end of the input and `deletAtEnd` +-- should discard any unconsumed input at the end of a successful parse. class Eof state where eof :: state -> Bool deleteAtEnd :: state -> Maybe (Cost, state) --- ** `Location` --- | The input state may contain a location which can be used in error messages. Since we do not want to fix our input to be just a @String@ we provide an interface--- which can be used to advance the location by passing its information in the function splitState+-- | The input state may maintain a location which can be used in generating error messages. +-- Since we do not want to fix our input to be just a @String@ we provide an interface+-- which can be used to advance this location by passing information about the part recognised. This function is typically+-- called in the `splitState` functions. class Show loc => loc `IsLocationUpdatedBy` str where advance::loc -> str -> loc --- ** 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 (Alternative p) => ExtAlternative p where- (<<|>) :: p a -> p a -> p a- (<-|->) :: p a -> p a -> p a- (<-|->) = (<|>)- +-- | The class `StoresErrors` is used by the function `pErrors` which retreives the generated +-- correction steps since the last time it was called.+-- --- * The triples containg a history, a future parser and a recogniser: @`T`@--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Triples %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- actual parsers-data T st a = T (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+class state `StoresErrors` error | state -> error where+ -- | `getErrors` retrieves the correcting steps made since the last time the function was called. The result can, + -- by using it in a monad, be used to control how to proceed with the parsing process.+ getErrors :: state -> ([error], state) ++class state `HasPosition` pos | state -> pos where+ -- | `getPos` retreives the correcting steps made since the last time the function was called. The result can, + -- by usingit as the left hand sie of a mondaic bind, be used to control how to proceed with the parsing process.+ getPos :: state -> pos++-- | The data type `T` contains three components, all being some form of primitive parser. +-- These components are used in various combinations,+-- depending on whether you are in the right and side operand of a monad, +-- whether you are interested in a result (if not, we use recognisers), +-- and whether you want to have the results in an online way (future parsers), or just prefer to be a bit faster (history parsers)++data T st a = T (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 + instance Functor (T st) where fmap f (T ph pf pr) = T ( \ k -> ph ( k .f ))- ( \ k -> pushapply f . pf k) -- pure f <*> pf+ ( \ k -> apply2fst f . pf k) -- pure f <*> pf pr f <$ (T _ _ pr) = T ( pr . ($f)) ( \ k st -> push f ( pr k st)) pr --- ** Triples are Applicative: @`<*>`@, @`<*`@, @`*>`@ and @`pure`@ instance Applicative (T state) where T ph pf pr <*> ~(T qh qf qr) = T ( \ k -> ph (\ pr -> qh (\ qr -> k (pr qr)))) ((apply .) . (pf .qf))@@ -81,44 +170,34 @@ (\ k inp -> pr k inp `best` qr k inp) empty = T ( \ k inp -> noAlts) ( \ k inp -> noAlts) ( \ k inp -> noAlts) -{---- instance ExtAlternative (T st) where --- unfortunatelythis is not possible since we have to make the choice for swapping elsewhere--} --instance ExtAlternative Maybe where- Nothing <<|> r = r- l <<|> Nothing = l - l <<|> r = l -- choosing the high priority alternative ? is this the right choice?----- * The descriptor @`P`@ of a parser, including the tupled parser corresponding to this descriptor--- data P st a = P (T st a) -- actual parsers (Maybe (T st a)) -- non-empty parsers; Nothing if they are absent- Nat -- minimal length- (Maybe a) -- possibly empty with value + Nat -- minimal length of the non-empty part+ (Maybe a) -- the possibly empty alternative with value + instance Show (P st a) where show (P _ nt n e) = "P _ " ++ maybe "Nothing" (const "(Just _)") nt ++ " (" ++ show n ++ ") " ++ maybe "Nothing" (const "(Just _)") e +-- | `getOneP` retreives the non-zero part from a descriptor getOneP :: P a b -> Maybe (P a b)-getOneP (P _ (Just _) Zero _ ) = error "The element is a special parser which cannot be combined"-getOneP (P _ Nothing l _ ) = Nothing-getOneP (P _ onep l ep ) = Just( P (mkParser onep Nothing) onep l Nothing)+-- getOneP (P _ (Just _) (Zero Unspecified) _ ) = error "The element is a special parser which cannot be combined"+getOneP (P _ Nothing l _ ) = Nothing+getOneP (P _ onep l ep ) = Just( mkParser onep Nothing (getLength l)) -getZeroP :: P t a -> Maybe (P st a)-getZeroP (P _ _ l Nothing) = Nothing-getZeroP (P _ _ l pe) = Just (P (mkParser Nothing pe) Nothing l pe) -- TODO check for erroneous parsers+-- | `getZeroP` retreives the possibly empty part from a descriptor+getZeroP :: P t a -> Maybe a+getZeroP (P _ _ _ z) = z -mkParser :: Maybe (T st a) -> Maybe a -> T st a-mkParser np@Nothing ne@Nothing = empty -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` combines the non-empty descriptor part and the empty descriptor part into a descriptor tupled with the parser triple+mkParser :: Maybe (T st a) -> Maybe a -> Nat -> P st a+mkParser np@Nothing ne@Nothing l = P empty np l ne +mkParser np@(Just nt) ne@Nothing l = P nt np l ne +mkParser np@Nothing ne@(Just a) l = P (pure a) np l ne +mkParser np@(Just nt) ne@(Just a) l = P (nt <|> pure a) np l ne --- combine creates the non-empty parser +-- ! `combine` creates the non-empty parser combine :: (Alternative f) => Maybe t1 -> Maybe t2 -> t -> Maybe t3 -> (t1 -> t -> f a) -> (t2 -> t3 -> f a) -> Maybe (f a) combine Nothing Nothing _ _ _ _ = Nothing -- this Parser always fails@@ -130,117 +209,61 @@ Just nnq -> Just (v `op2` nnq) -- right hand side has non-empty part Nothing -> Nothing -- neither side has non-empty part --- ** Parsers are functors: @`fmap`@ instance Functor (P state) where - fmap f (P ap np l me) = let nnp = fmap (fmap f) np- nep = f <$> me - in P (mkParser nnp nep) nnp l nep- f <$ (P ap np l me) = let nnp = fmap (f <$) np- nep = f <$ me - in P (mkParser nnp nep) nnp l nep-+ fmap f (P ap np l me) = mkParser (fmap (fmap f) np) (f <$> me) l + f <$ (P ap np l me) = mkParser (fmap (f <$) np) (f <$ me) l --- ** Parsers are Applicative: @`<*>`@, @`<*`@, @`*>`@ and @`pure`@ instance Applicative (P state) where- P ap np pl pe <*> ~(P aq nq ql qe) = let newnp = combine np pe aq nq (<*>) (<$>)- newlp = nat_add pl ql- newep = pe <*> qe- in P (mkParser newnp newep) newnp newlp newep- P ap np pl pe <* ~(P aq nq ql qe) = let newnp = combine np pe aq nq (<*) (<$)- newlp = nat_add pl ql- newep = pe <* qe- in P (mkParser newnp newep) newnp newlp newep- P ap np pl pe *> ~(P aq nq ql qe) = let newnp = combine np pe aq nq (*>) (flip const)- newlp = nat_add pl ql- newep = pe *> qe- in P (mkParser newnp newep) newnp newlp newep- pure a = P (pure a) Nothing Zero (Just a)-+ P ap np pl pe <*> ~(P aq nq ql qe) = mkParser (combine np pe aq nq (<*>) (<$>)) (pe <*> qe) (nat_add pl ql) + P ap np pl pe <* ~(P aq nq ql qe) = mkParser (combine np pe aq nq (<*) (<$)) (pe <* qe ) (nat_add pl ql)+ P ap np pl pe *> ~(P aq nq ql qe) = mkParser (combine np pe aq nq (*>) (flip const)) (pe *> qe ) (nat_add pl ql) + pure a = mkParser Nothing (Just a ) (Zero Infinite) - --- ** Parsers are Alternative: @`<|>`@ and @`empty`@ -instance Alternative (P state) where +instance Alternative (P state) where P ap np pl pe <|> P aq nq ql qe = let (rl, b) = trace' "calling natMin from <|>" (nat_min pl ql 0) Nothing `alt` q = q p `alt` Nothing = p Just p `alt` Just q = Just (p <|>q)- 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 -- 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--- get a complete Parsec equivalent behaviour, with all its (dis)advantages. use with are!+ in mkParser ((if b then flip else id) alt np nq) (pe <|> qe) rl+ empty = mkParser empty empty Infinite instance ExtAlternative (P st) where P ap np pl pe <<|> P aq nq ql qe = let (rl, b) = nat_min pl ql 0 bestx :: Steps a -> Steps a -> Steps a- bestx = if b then flip best else best+ bestx = (if b then flip else id) best choose:: T st a -> T st a -> T st a choose (T ph pf pr) (T qh qf qr) = T (\ k st -> let left = norm (ph k st) in if has_success left then left else left `bestx` qh k st) (\ k st -> let left = norm (pf k st) in if has_success left then left else left `bestx` qf k st) - (\ k st -> let left = norm (pr k st)- in if has_success left then left else left `bestx` qr k st)+ (\ k st -> let left = norm (pr k st)+ in if has_success left then left else left `bestx` qr k st) in P (choose ap aq ) (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 --- 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. --- The function `pSymExt` 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 holds the input. The functional dependency fixes the `token` type, --- based on the `symbol` type and the type of the parser `p`.---- | Since `pSymExt' is overloaded both the type and the value of a symbol --- determine how to decompose the input in a `token` and the remaining input.--- `pSymExt` takes two extra parameters: the first describing the minimal number of tokens recognised, --- and the second telling whether the symbol can recognise the empty string and the value which is to be returned in that case- -pSymExt :: (Provides state symbol token) => Nat -> Maybe token -> symbol -> P state token-pSymExt l e a = P t (Just t) l e- where t = T ( \ k inp -> splitState a k inp)- ( \ k inp -> splitState a (\ t inp' -> push t (k inp')) inp)- ( \ k inp -> splitState a (\ _ inp' -> k inp') inp)---- | @`pSym`@ covers the most common case of recognsiing a symbol: a single token is removed form the input, --- and it cannot recognise the empty string-pSym :: (Provides state symbol token) => symbol -> P state token-pSym s = pSymExt (Succ Zero) Nothing s ----- ** Parsers are Monads: @`>>=`@ and @`return`@--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Monads %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--unParser_h :: P b a -> (a -> b -> Steps r) -> b -> Steps r-unParser_h (P (T h _ _ ) _ _ _ ) = h+ P _ np pl pe <?> label = let replaceExpected :: Steps a -> Steps a+ replaceExpected (Fail _ c) = (Fail [label] c)+ replaceExpected others = others+ nnp = case np of Nothing -> Nothing+ Just ((T ph pf pr)) -> Just(T ( \ k inp -> replaceExpected (norm ( ph k inp)))+ ( \ k inp -> replaceExpected (norm ( pf k inp)))+ ( \ k inp -> replaceExpected (norm ( pr k inp))))+ in mkParser nnp pe pl+ -- | `doNotInterpret` forgets the computed minimal number of tokens recognised by this parser+ doNotInterpret (P t nep _ e) = P t nep Unspecified e+ 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 _ _ q = q+ must_be_non_empties msg (P _ _ (Zero _) _) (P _ _ (Zero _) _ ) _ + = error ("The combinator " ++ msg ++ " requires that not both arguments can recognise the empty string\n")+ must_be_non_empties _ _ _ q = q -unParser_f :: P b a -> (b -> Steps r) -> b -> Steps (a, r)-unParser_f (P (T _ f _ ) _ _ _ ) = f+instance IsParser (P st) -unParser_r :: P b a -> (b -> Steps r) -> b -> Steps r-unParser_r (P (T _ _ r ) _ _ _ ) = r- -- !! do not move the P constructor behind choices/patern matches instance Monad (P st) where p@(P ap np lp ep) >>= a2q = @@ -251,38 +274,35 @@ in (eq, combine t nq , t `alt` aq) Nothing `alt` q = q Just p `alt` q = p <|> q- t = case np of- Nothing -> Nothing- Just (T h _ _ ) -> Just (T ( \k -> h (\ a -> unParser_h (a2q a) k))- ( \k -> h (\ a -> unParser_f (a2q a) k))- ( \k -> h (\ a -> unParser_r (a2q a) k)))+ t = fmap (\ (T h _ _ ) -> (T ( \k -> h (\ a -> unParser_h (a2q a) k))+ ( \k -> h (\ a -> unParser_f (a2q a) k))+ ( \k -> h (\ a -> unParser_r (a2q a) k))) ) np combine Nothing Nothing = Nothing combine l@(Just _ ) Nothing = l combine Nothing r@(Just _ ) = r combine (Just l) (Just r) = Just (l <|> r)+ -- | `unParser_h` retreives the history parser from the descriptor+ unParser_h :: P b a -> (a -> b -> Steps r) -> b -> Steps r+ unParser_h (P (T h _ _ ) _ _ _ ) = h+ -- | `unParser_f` retreives the future parser from the descriptor+ unParser_f :: P b a -> (b -> Steps r) -> b -> Steps (a, r)+ unParser_f (P (T _ f _ ) _ _ _ ) = f+ -- | `unParser_r` retreives therecogniser from the descriptor+ unParser_r :: P b a -> (b -> Steps r) -> b -> Steps r+ unParser_r (P (T _ _ r ) _ _ _ ) = r return = pure ---- * Additional useful combinators--- | The parsers build a list of symbols which are expected at a specific point. --- This list is used to report errors.--- Quite often it is more informative to get e.g. the name of the non-terminal. --- The @`<?>`@ combinator replaces this list of symbols by it's righ-hand side argument.--(<?>) :: P state a -> String -> P state a-P _ np pl pe <?> label - = let nnp = case np of- Nothing -> Nothing- Just ((T ph pf pr)) -> Just(T ( \ k inp -> replaceExpected (norm ( ph k inp)))- ( \ k inp -> replaceExpected (norm ( pf k inp)))- ( \ k inp -> replaceExpected (norm ( pr k inp))))- replaceExpected :: Steps a -> Steps a- replaceExpected (Fail _ c) = (Fail [label] c)- replaceExpected others = others- in P (mkParser nnp pe) nnp pl pe-+-- | The function `pSymExt` converts a very basic parser, passed to at as the function `splitState`, +-- the minmal number of tokens recognised by the function and and empty descriptor, and builds a @P@ parser out of this, +-- i.e. lift the behaviour to a fture pareser, a histroy parser and a recogniser. +pSymExt :: (forall a. (token -> state -> Steps a) -> state -> Steps a) -> Nat -> Maybe token -> P state token+pSymExt splitState l e = mkParser (Just t) e l+ where t = T ( splitState )+ ( \ k -> splitState (\ t -> push t . k) )+ ( \ k -> splitState (\ _ -> k ) ) --- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; for its use see `Text.ParserCombinators.UU.Examples` +-- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; +-- for its use see `"Text.ParserCombinators.UU.Demos.Examples"` micro :: P state a -> Int -> P state a P _ np pl pe `micro` i = let nnp = case np of@@ -290,10 +310,10 @@ Just ((T ph pf pr)) -> Just(T ( \ k st -> ph (\ a st -> Micro i (k a st)) st) ( \ k st -> pf (Micro i .k) st) ( \ k st -> pr (Micro i .k) st))- in P (mkParser nnp pe) nnp pl pe+ in mkParser nnp pe pl --- For the precise functioning of the combinators we refer to the technical report mentioned in the README file--- @`amb`@ converts an ambiguous parser into a parser which returns a list of possible recognitions.+-- | For the precise functioning of the `amb` combinators see the paper cited in the "Text.ParserCombinators.UU.README";+-- it converts an ambiguous parser into a parser which returns a list of possible recognitions, amb :: P st a -> P st [a] amb (P _ np pl pe) = let combinevalues :: Steps [(a,r)] -> Steps ([a],r)@@ -304,41 +324,34 @@ ( \k inp -> combinevalues . removeEnd_f $ pf (\st -> End_f [k st] noAlts) inp) ( \k -> removeEnd_h . pr (\ st' -> End_h ([undefined], \ _ -> k st') noAlts))) nep = (fmap pure pe)- in P (mkParser nnp nep) nnp pl nep----- | `getErrors` retreives the correcting steps made since the last time the function was called. The result can, --- using a monad, be used to control how to proceed with the parsing process.--class state `Stores` error | state -> error where- getErrors :: state -> ([error], state)+ in mkParser nnp nep pl --- | The class @`Stores`@ is used by the function @`pErrors`@ which retreives the generated correction spets since the last time it was called.----pErrors :: Stores st error => P st [error]+-- | `pErrors` returns the error messages that were generated since its last call+pErrors :: StoresErrors st error => P st [error] 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' )) nep = (Just (error "pErrors cannot occur in lhs of bind")) -- the errors consumed cannot be determined statically!- in P (mkParser nnp Nothing) nnp Zero Nothing----- | @`pPos`@ retreives the correcting steps made since the last time the function was called. The result can, --- using a monad, be used to control how to-- proceed with the parsing process.--class state `HasPosition` pos | state -> pos where- getPos :: state -> pos+ in mkParser nnp Nothing (Zero Infinite) +-- | `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 -> let pos = getPos inp in k inp ))+ ( \ k inp -> let pos = getPos inp in push pos (k inp))+ ( \ k inp -> k inp )) nep = Just (error "pPos cannot occur in lhs of bind") -- the errors consumed cannot be determined statically!- in P (mkParser nnp Nothing) nnp Zero Nothing+ in mkParser nnp Nothing (Zero Infinite) +-- | `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) + -- | The function `pEnd` should be called at the end of the parsing process. It deletes any unconsumed input, turning them into error messages -pEnd :: (Stores st error, Eof st) => P st [error]+pEnd :: (StoresErrors st error, Eof st) => P st [error] pEnd = let nnp = Just ( T ( \ k inp -> let deleterest inp = case deleteAtEnd inp of Nothing -> let (finalerrors, finalstate) = getErrors inp in k finalerrors finalstate@@ -354,18 +367,8 @@ in (k finalstate) Just (i, inp') -> Fail [] [const (i, deleterest inp')] in deleterest inp))- in P (mkParser nnp Nothing) nnp Zero Nothing+ in mkParser nnp Nothing (Zero Infinite) ---- The function @`parse`@ shows the prototypical way of running a parser on a some specific input--- By default we use the future parser, since this gives us access to partal 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 (error "ambiguous parser?")))) - else error "pEnd missing?")-parse_h (P (T ph _ _) _ _ _) = fst . eval . ph (\ a rest -> if eof rest then push a (Step 0 (Step 0 (Step 0 (Step 0 (error "ambiguous parser?"))))) - else error "pEnd missing?") - -- | @`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 valuee of the original type. -- For the second argumnet to @`pSwitch`@ (say split) we expect the following to hold:@@ -380,39 +383,63 @@ in pf (\st2' -> k (back st2')) st2) (\ k st1 -> let (st2, back) = split st1 in pr (\st2' -> k (back st2')) st2)) np- in P (mkParser nnp pe) nnp pl pe+ in mkParser nnp pe pl --- * Maintaining Progress Information--- | The data type @`Steps`@ is the core data type around which the parsers are constructed.++-- | 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+-- 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 (error "ambiguous parser?")))) + else error "pEnd missing?")+-- | 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 (error "ambiguous parser?"))))) + else error "pEnd missing?") ++-- | The data type `Steps` is the core data type around which the parsers are constructed. -- It is a describes a tree structure of streams containing (in an interleaved way) both the online result of the parsing process, -- and progress information. Recognising an input token should correspond to a certain amount of @`Progress`@, -- which tells how much of the input state was consumed. -- The @`Progress`@ is used to implement the breadth-first search process, in which alternatives are -- examined in a more-or-less synchonised way. The meaning of the various @`Step`@ constructors is as follows: ----- [@`Step`@] A token was succesfully recognised, and as a result the input was 'advanced' by the distance @`Progress`@+-- [`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.+-- [`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 information about what was expected in the input, +-- [`Fail`] A correcting step has to made to the input; the first parameter contains information about what was expected in the input, -- and the second parameter describes the various corrected alternatives, each with an associated `Cost` ----- [@`Micro`@] A small cost is inserted in the sequence, which is used to disambiguate. Use with care!+-- [`Micro`] A small cost is inserted in the sequence, which is used to disambiguate. Use with care! -- -- The last two alternatives play a role in recognising ambigous non-terminals. For a full description see the technical report referred to from the README file.. -type Cost = Int-type Progress = Int-type Strings = [String] + data Steps a where 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 :: Cost -> Steps a -> Steps a+ Micro :: Int -> Steps a -> Steps a End_h :: ([a] , [a] -> Steps r) -> Steps (a,r) -> Steps (a, r) End_f :: [Steps a] -> Steps a -> Steps a +type Cost = Int+type Progress = Int+type Strings = [String]++apply :: Steps (b -> a, (b, r)) -> Steps (a, r)+apply = Apply (\(b2a, br) -> let (b, r) = br in (b2a b, r)) ++push :: v -> Steps r -> Steps (v, r)+push v = Apply (\ r -> (v, r))++apply2fst :: (b -> a) -> Steps (b, r) -> Steps (a, r)+apply2fst f = Apply (\ (b, r) -> (f b, r)) + succeedAlways :: Steps a succeedAlways = let steps = Step 0 steps in steps @@ -438,16 +465,8 @@ 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)) --pushapply :: (b -> a) -> Steps (b, r) -> Steps (a, r)-pushapply f = Apply (\ (b, r) -> (f b, r)) ---- | @`norm`@ makes sure that the head of the seqeunce contains progress information. It does so by pushing information about the result (i.e. the @Apply@ steps) backwards.+-- | `norm` makes sure that the head of the seqeunce contains progress information. +-- It does so by pushing information about the result (i.e. the `Apply` steps) backwards. -- norm :: Steps a -> Steps a norm (Apply f (Step p l )) = Step p (Apply f l)@@ -466,26 +485,26 @@ x `best` y = norm x `best'` norm y best' :: Steps b -> Steps b -> Steps b+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) Fail sl ll `best'` Fail sr rr = Fail (sl ++ sr) (ll++rr)-Fail _ _ `best'` r = r+Fail _ _ `best'` r = r -- <----------------------------- to be refined 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)+ | 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) ls@(Step _ _) `best'` Micro _ _ = ls Micro _ _ `best'` rs@(Step _ _) = rs ls@(Micro i l) `best'` rs@(Micro j r) - | i == j = Micro i (l `best'` r)+ | i == j = Micro i (l `best` r) | i < j = ls | i > j = rs-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 +l `best'` r = error "missing alternative in best'" -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% getCheapest %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%@@ -538,60 +557,45 @@ `best` removeEnd_f r --- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%% Auxiliary Functions and Types %%%%%%%%%%%%%%%%%%%--- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%---- * Auxiliary functions and types--- ** Checking for non-sensical combinations: @`must_be_non_empty`@ and @`must_be_non_empties`@--- | The function checks wehther its second argument is a parser which can recognise the mety sequence. If so an error message is given--- using the name of the context. If not then the third argument is returned. This is useful in testing for loogical combinations. For its use see--- the module Text>parserCombinators.UU.Derived--must_be_non_empty :: [Char] -> P t t1 -> t2 -> t2-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 _ _ q = q---- | This function is similar to the above, but can be used in situations where we recognise a sequence of elements separated by other elements. This does not --- make sense if both parsers can recognise the empty string. Your grammar is then highly ambiguous.--must_be_non_empties :: [Char] -> P t1 t -> P t3 t2 -> t4 -> t4-must_be_non_empties msg (P _ _ Zero _) (P _ _ Zero _ ) _ - = error ("The combinator " ++ msg ++ " requires that not both arguments can recognise the empty string\n")-must_be_non_empties msg _ _ q = q-- -- ** 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+data Nat = Zero Nat -- the length of the non-zero part of the parser is remembered) | Succ Nat | Infinite+ | Unspecified deriving Show -nat_min :: Nat -> Nat -> Int -> (Nat, Bool)-nat_min _ Zero _ = trace' "Right Zero in nat_min\n" (Zero, False)-nat_min Zero _ _ = trace' "Left Zero in nat_min\n" (Zero, True)-nat_min Infinite r _ = trace' "Left Infinite in nat_min\n" (r, False) -nat_min l Infinite _ = trace' "Right Infinite in nat_min\n" (l, True) -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))+-- | `getlength` retrieves the length of the non-empty part of a parser+getLength :: Nat -> Nat+getLength (Zero l) = l+getLength l = l -nat_add :: Nat -> Nat -> Nat-nat_add Infinite _ = trace' "Infinite in add\n" Infinite-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_min` compares two minmal length and returns the shorter length. The second component indicates whether the left+-- operand is the smaller one; we cannot use @Either@ since the fisrt component may already be inspected +-- before we know which operand is finally chosen+nat_min :: Nat -> Nat -> Int -> ( Nat -- the actual minimum length+ , Bool -- whether aternatives should be swapped+ ) +nat_min (Zero l) (Zero r) n = (Zero (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 (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))+nat_min Infinite r _ = trace' "Left Infinite in nat_min\n" (r, True) +nat_min l Infinite _ = trace' "Right Infinite in nat_min\n" (l, False) +nat_min Unspecified r _ = (r, False) -- leave the alternatives in the order they are +nat_min l Unspecified _ = (l, False) -- leave the alternatives in the order they are -get_length :: P a b -> Nat-get_length (P _ _ l _) = l+nat_add :: Nat -> Nat -> Nat+nat_add Unspecified _ = Unspecified+nat_add Infinite _ = trace' "Infinite in add\n" Infinite+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)) trace' :: String -> b -> b trace' m v = {- trace m -} v ------
+ src/Text/ParserCombinators/UU/Demo/Examples.hs view
@@ -0,0 +1,271 @@+{-# OPTIONS_HADDOCK ignore-exports #-}+{-# LANGUAGE FlexibleInstances,+ TypeSynonymInstances,+ MultiParamTypeClasses,+ Rank2Types, FlexibleContexts, NoMonomorphismRestriction,+ CPP #-}++-- | This module contains a lot of examples of the typical use of our parser combinator library. +-- We strongly encourage you to take a look at the source code+-- At the end you find a @`main`@ function which demonstrates the main characteristics. +-- Only the @`run`@ function is exported since it may come in handy elsewhere.++module Text.ParserCombinators.UU.Demo.Examples where+import Data.Char+import Text.ParserCombinators.UU +import Text.ParserCombinators.UU.Utils+import Text.ParserCombinators.UU.BasicInstances+import System.IO+import GHC.IO.Handle.Types++-- import Control.Monad++#define DEMO(p,i) demo "p" i p++justamessage = "justamessage"++-- | Running the function `show_demos` should give the following output:+--+-- >>> run pa "a"+-- Result: "a"+-- +-- >>> run pa ""+-- Result: "a"+-- Correcting steps: +-- Inserted 'a' at position LineColPos 0 0 0 expecting 'a'+-- +-- >>> run pa "b"+-- Result: "a"+-- Correcting steps: +-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'+-- Inserted 'a' at position LineColPos 0 1 1 expecting 'a'+-- +-- >>> run ((++) <$> pa <*> pa) "bbab"+-- Result: "aa"+-- Correcting steps: +-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'+-- Deleted 'b' at position LineColPos 0 1 1 expecting 'a'+-- Deleted 'b' at position LineColPos 0 3 3 expecting 'a'+-- Inserted 'a' at position LineColPos 0 4 4 expecting 'a'+-- +-- >>> run pa "ba"+-- Result: "a"+-- Correcting steps: +-- Deleted 'b' at position LineColPos 0 0 0 expecting 'a'+-- +-- >>> run pa "aa"+-- Result: "a"+-- Correcting steps: +-- The token 'a' was not consumed by the parsing process.+-- +-- >>> run (pCount pa :: Parser Int) "aaa"+-- Result: 3+-- +-- >>> run (do {l <- pCount pa; pExact l pb}) "aaacabbbbb"+-- Result: ["b","b","b","b"]+-- Correcting steps: +-- Deleted 'c' at position LineColPos 0 3 3 expecting one of ['b', 'a']+-- The token 'b' was not consumed by the parsing process.+-- +-- >>> run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaaaa"+-- Result: ["aaaaa","aaaaa"]+-- +-- >>> run (pList pLower) "doaitse"+-- Result: "doaitse"+-- +-- >>> run paz "abc2ez"+-- Result: "abcez"+-- Correcting steps: +-- Deleted '2' at position LineColPos 0 3 3 expecting 'a'..'z'+-- +-- >>> run (max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0) "((()))()(())"+-- Result: 3+-- +-- >>> run (pa <|> pb <?> justamessage) "c"+-- Result: "b"+-- Correcting steps: +-- Deleted 'c' at position LineColPos 0 0 0 expecting justamessage+-- Inserted 'b' at position LineColPos 0 1 1 expecting 'b'+-- +-- >>> run (amb (pEither parseIntString pIntList)) "(123;456;789)"+-- Result: [Left ["123","456","789"],Right [123,456,789]]+-- +show_demos :: IO ()+show_demos = + do DEMO (pa, "a")+ DEMO (pa, "" )+ DEMO (pa, "b")+ DEMO (((++) <$> pa <*> pa), "bbab")+ DEMO (pa, "ba")+ DEMO (pa, "aa")+ DEMO ((pCount pa :: Parser Int), "aaa")+ DEMO ((do {l <- pCount pa; pExact l pb}), "aaacabbbbb")+ DEMO ((amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)), "aaaaa")+ DEMO ((pList pLower), "doaitse")+ DEMO (paz, "abc2ez")+ DEMO ((max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0), "((()))()(())")+ DEMO ((pa <|> pb <?> justamessage), "c")+ DEMO ((amb (pEither parseIntString pIntList)), "(123;456;789)")+-- DEMO ((pa *> pMunch ( `elem` "^=*") <* pb), "a^=^**^^b")++-- | The fuction @`run`@ runs the parser and shows both the result, and the correcting steps which were taken during the parsing process.+run :: Show t => Parser t -> String -> IO ()+run p inp = do let r@(a, errors) = parse ( (,) <$> p <*> pEnd) (createStr (LineColPos 0 0 0) inp)+ putStrLn ("-- Result: " ++ show a)+ if null errors then return ()+ else do putStr ("-- Correcting steps: \n")+ show_errors errors+ putStrLn "-- "+ where show_errors :: (Show a) => [a] -> IO ()+ show_errors = sequence_ . (map (putStrLn . show))++-- | Our first two parsers are simple; one recognises a single 'a' character and the other one a single 'b'. Since we will use them later we +-- convert the recognsised character into `String` so they can be easily combined.+pa ::Parser String +pa = lift <$> pSym 'a'+pb :: Parser String +pb = lift <$> pSym 'b'+pc :: Parser String +pc = lift <$> pSym 'c'+lift a = [a]++(<++>) :: Parser String -> Parser String -> Parser String+p <++> q = (++) <$> p <*> q+pa2 = pa <++> pa+pa3 = pa <++> pa2++paz :: Parser String+paz = pList (pSatisfy (\t -> 'a' <= t && t <= 'z') (Insertion "'a'..'z'" 'k' 5)) ++-- | The applicative style makes it very easy to merge recogition and computing a result. +-- As an example we parse a sequence of nested well formed parentheses pairs and+-- compute the maximum nesting depth with @`wfp`@: +wfp :: Parser Int+wfp = max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0++-- | It is very easy to recognise infix expressions with any number of priorities and operators:+--+-- > operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]+-- > same_prio ops = msum [ op <$ pSym c | (c, op) <- ops]+-- > expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators) -- +--+-- which we can call: +--+-- > run expr "15-3*5+2^5"+--+-- > Result: 32+--+-- Note that also here correction takes place: +--+-- > run expr "2 + + 3 5"+--+-- > Result: 37+-- > Correcting steps: +-- > Deleted ' ' at position 1 expecting one of ['0'..'9', '^', '*', '-', '+']+-- > Deleted ' ' at position 3 expecting one of ['(', '0'..'9']+-- > Inserted '0' at position 4 expecting '0'..'9'+-- > Deleted ' ' at position 5 expecting one of ['(', '0'..'9']+-- > Deleted ' ' at position 7 expecting one of ['0'..'9', '^', '*', '-', '+']+-- +++test11 = run expr "15-3*5"+expr :: Parser Int+operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]+same_prio ops = foldr (<|>) empty [ op <$ pSym c | (c, op) <- ops]+expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators) +++-- | A common case where ambiguity arises is when we e.g. want to recognise identifiers, +-- but only those which are not keywords. +-- The combinator `micro` inserts steps with a specfied cost in the result +-- of the parser which can be used to disambiguate:+--+-- > +-- > ident :: Parser String+-- > ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces+-- > idents = pList1 ident+-- > pKey keyw = pToken keyw `micro` 1 <* spaces+-- > spaces :: Parser String+-- > spaces = pMunch (==' ')+-- > takes_second_alt = pList ident +-- > \<|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e) +-- > \<$ pKey "if" <*> pList_ng ident +-- > \<* pKey "then" <*> pList_ng ident+-- > \<* pKey "else" <*> pList_ng ident +--+-- A keyword is followed by a small cost @1@, which makes sure that +-- identifiers which have a keyword as a prefix win over the keyword. Identifiers are however+-- followed by a cost @2@, with as result that in this case the keyword wins. +-- Note that a limitation of this approach is that keywords are only recognised as such when expected!+-- +-- > test13 = run takes_second_alt "if a then if else c"+-- > test14 = run takes_second_alt "ifx a then if else c"+-- +-- with results for @test13@ and @test14@:+--+-- > Result: ["IfThenElse","a","if","c"]+-- > Result: ["ifx","a","then","if", "else","c"]+-- ++-- | A mistake which is made quite often is to construct a parser which can recognise a sequence of elements using one of the +-- derived combinators (say @`pList`@), but where the argument parser can recognise the empty string. +-- The derived combinators check whether this is the case and terminate the parsing process with an error message:+--+-- > run (pList spaces) ""+-- > Result: *** Exception: The combinator pList+-- > requires that it's argument cannot recognise the empty string+--+-- > run (pMaybe spaces) " "+-- > Result: *** Exception: The combinator pMaybe+-- > requires that it's argument cannot recognise the empty string+test16 :: IO ()+test16 = run (pList spaces) " "++ident = ((:) <$> pRange ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces+idents = pList1 ident++pKey keyw = pToken keyw `micro` 1 <* spaces+spaces :: Parser String+spaces = pMunch (`elem` " \n")+ +takes_second_alt = pList ident + <|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e) + <$ pKey "if" <*> pList_ng ident + <* pKey "then" <*> pList_ng ident+ <* pKey "else" <*> pList_ng ident +test13 = run takes_second_alt "if a then if else c"+test14 = run takes_second_alt "ifx a then if else c"++++pManyTill :: P st a -> P st b -> P st [a]+pManyTill p end = [] <$ end + <<|> + (:) <$> p <*> pManyTill p end+simpleComment = string "<!--" *> pManyTill pAscii (string "-->")+++string :: String -> Parser String+string = pToken+++pVarId = (:) <$> pLower <*> pList pIdChar+pConId = (:) <$> pUpper <*> pList pIdChar+pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"++pAnyToken :: [String] -> Parser String+pAnyToken = pAny pToken++-- parsing two alternatives and returning both rsults+pIntList :: Parser [Int]+pIntList = pParens ((pSym ';') `pListSep` (read <$> pList1 (pRange ('0', '9'))))+parseIntString :: Parser [String]+parseIntString = pParens ((pSym ';') `pListSep` ( pList1 (pRange('0', '9'))))+++++demo :: Show r => String -> String -> Parser r -> IO ()+demo str input p= do putStr ("-- >>> run " ++ str ++ " " ++ show input ++ "\n")+ run p input
+ src/Text/ParserCombinators/UU/Demo/MergeAndPermute.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE NoMonomorphismRestriction,+ RankNTypes,+ FlexibleContexts,+ CPP #-}+#define DEMO(p,i) demo "p" i p+#define DEMOG(p,i) demo "p" i (mkParserM (p))+module Text.ParserCombinators.UU.Demo.MergeAndPermute where++import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.MergeAndPermute+import Text.ParserCombinators.UU.BasicInstances+import Text.ParserCombinators.UU.Utils+import Text.ParserCombinators.UU.Demo.Examples hiding (show_demos)+import qualified Data.ListLike as LL ++type Grammar a = (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => Gram (P (Str Char state loc)) a++-- | By running the function `show_demos` you will get a demonstration of the merging parsers.+--+-- >>> run ((,,) <$> two pA <||> three pB <||> pBetween 2 4 pC ) "cababbcccc"+-- Result: ("aa",("b","b","b"),["c","c","c","c"])+-- Correcting steps: +-- The token 'c' was not consumed by the parsing process.+-- +-- >>> run (amb (mkParserM ((,) <$> pmMany ((,) <$> pA <*> pC) <||> pmMany pB))) "aabbcaabbccc"+-- Result: [([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),+-- ([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),+-- ([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),+-- ([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),+-- ([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),+-- ([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"]),([("a","c"),("a","c"),("a","c"),("a","c")],["b","b","b","b"])]+-- +-- >>> run (pmMany(pABC)) "a2a1b1b2c2a3b3c1c3"+-- Result: ["2a","1a","3a"]+-- +-- >>> run ((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pB) "abba"+-- Result: (["a","a"],["b","b"])+-- +-- >>> run ((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pB) "bba"+-- Result: (["a","a"],["b","b"])+-- Correcting steps: +-- Inserted 'a' at position LineColPos 0 3 3 expecting 'a'+-- +-- >>> run (amb (mkParserM( ((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pA)))) "aaa"+-- Result: [(["a","a"],["a"]),(["a","a"],["a"]),(["a","a"],["a"])]+-- +-- The 'a' at the right hand side can b any of the three 'a'-s in the input:+--+-- >>> run ((,) <$> pAtLeast 3 pA <||> pAtMost 3 pB) "aabbbb"+-- Result: (["a","a","a"],["b","b","b"])+-- Correcting steps: +-- Deleted 'b' at position LineColPos 0 5 5 expecting 'a'+-- Inserted 'a' at position LineColPos 0 6 6 expecting 'a'+-- +-- >>> run ((,) <$> pSome pA <||> pMany pB) "abba"+-- Result: (["a","a"],["b","b"])+-- +-- >>> run ((,) <$> pSome pA <||> pMany pB) "abba"+-- Result: (["a","a"],["b","b"])+-- +-- >>> run ((,) <$> pSome pA <||> pMany pB) ""+-- Result: (["a"],[])+-- Correcting steps: +-- Inserted 'a' at position LineColPos 0 0 0 expecting one of ['a', 'b']+-- +-- >>> run ((,) <$> pMany pB <||> pSome pC) "bcbc"+-- Result: (["b","b"],["c","c"])+-- +-- >>> run ((,) <$> pSome pB <||> pMany pC) "bcbc"+-- Result: (["b","b"],["c","c"])+-- +-- >>> run ((,,,) <$> pSome pA <||> pMany pB <||> pC <||> (pNat `opt` 5) ) "bcab45"+-- Result: (["a"],["b","b"],"c",45)+-- +-- >>> run ((,) <$> pMany (pA <|> pB) <||> pSome pNat) "1ab12aab14"+-- Result: (["a","b","a","a","b"],[1,12,14])+-- +-- >>> run ( (,) <$> ((++) <$> pMany pA <||> pMany pB) <||> pC) "abcaaab"+-- Result: (["a","a","a","a","b","b"],"c")+-- +-- >>> run (pc `mkParserS` ((,) <$> pMany pA <||> pMany pB)) "acbcacb"+-- Result: (["a","a"],["b","b"])+-- ++show_demos :: IO ()+show_demos = do DEMOG (((,,) <$> two pA <||> three pB <||> pBetween 2 4 pC ), "cababbcccc")+ DEMO ((amb (mkParserM ((,) <$> pmMany ((,) <$> pA <*> pC) <||> pmMany pB))) , "aabbcaabbccc")+ DEMOG ((pmMany(pABC)) , "a2a1b1b2c2a3b3c1c3")+ DEMOG (((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pB) , "abba") + DEMOG (((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pB) , "bba")+ DEMO ((amb (mkParserM( ((,) <$> pBetween 2 3 pA <||> pBetween 1 2 pA)))) , "aaa")+ putStr "-- The 'a' at the right hand side can b any of the three 'a'-s in the input\n"+ DEMOG (((,) <$> pAtLeast 3 pA <||> pAtMost 3 pB) , "aabbbb") + DEMOG (((,) <$> pSome pA <||> pMany pB) , "abba") + DEMOG (((,) <$> pSome pA <||> pMany pB) , "abba") + DEMOG (((,) <$> pSome pA <||> pMany pB) , "") + DEMOG (((,) <$> pMany pB <||> pSome pC) , "bcbc") + DEMOG (((,) <$> pSome pB <||> pMany pC) , "bcbc")+ DEMOG (((,,,) <$> pSome pA <||> pMany pB <||> pC <||> (pNat `opt` 5) ) , "bcab45" )+ DEMOG (((,) <$> pMany (pA <|> pB) <||> pSome pNat) , "1ab12aab14")+ DEMOG (( (,) <$> ((++) <$> pMany pA <||> pMany pB) <||> pC) , "abcaaab")+ DEMO ((pc `mkParserS` ((,) <$> pMany pA <||> pMany pB)) , "acbcacb")++pA, pB, pC:: Grammar String+pA = mkGram pa+pB = mkGram pb+pC = mkGram (lift <$> pSym 'c')+++pNat :: Grammar Int+pNat = mkGram pNatural+++pDigit' = mkGram pDigit++-- | `two` recognises two instance of p as part of the input sequence+two :: Applicative f => f [a] -> f [a]+two p = (++) <$> p <*> p+-- | `three` recognises two instance of p as part of the input sequence and concatenates the results+three :: Applicative f => f a-> f (a,a,a)+three p = (,,) <$> p <*> p <*> p++-- | `pABC` minimcs a series of events (here an @a@, a @b@ and a @c@), which belong to the same transaction. +-- The transaction is identified by a digit: hence a full transaction is a string like \"a5b5c5\". +-- The third element in the body of `show_demos` below shows how the different transactions can be recovered from +-- a log-file which contains all events generated by a collection of concurrently running transactions.+pABC :: Grammar String+pABC = (\ a d -> d:a) <$> pA <*> (pDigit' >>= \d -> pB *> mkGram (pSym d) *> pC *> mkGram (pSym d))++++
src/Text/ParserCombinators/UU/Derived.hs view
@@ -9,261 +9,169 @@ module Text.ParserCombinators.UU.Derived where import Text.ParserCombinators.UU.Core-import Control.Monad +import Control.Applicative+ -- | This module contains a large variety of combinators for list-lile structures. the extension @_ng@ indiactes that -- that variant is the non-greedy variant.--- See the "Text.ParserCombinators.UU.Examples" module for some exmaples of their use.+-- See the "Text.ParserCombinators.UU.Demo.Examples" module for some examples of their use. --- * Some common combinators for oft occurring constructs+-- * Some aliases for oft occurring constructs -- | @`pReturn`@ is defined for upwards comptaibility ---pReturn :: a -> P str a+pReturn :: Applicative p => a -> p a pReturn = pure -- | @`pFail`@ is defined for upwards comptaibility, and is the unit for @<|>@ ---pFail :: P str a+pFail :: Alternative p => p a 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 = must_be_non_empty "opt" p (p <<|> pure v) ---- | @pMaybe@ greedily recognises its argument. If not @Nothing@ is returned.+-- | `pMaybe` greedily recognises its argument. If not @Nothing@ is returned. ---pMaybe :: P st a -> P st (Maybe a)+pMaybe :: IsParser p => p a -> p (Maybe a) pMaybe p = must_be_non_empty "pMaybe" p (Just <$> p `opt` Nothing) --- | @pEither@ recognises either one of its arguments.+-- | `pEither` recognises either one of its arguments. ---pEither :: P str a -> P str b -> P str (Either a b)+pEither :: IsParser p => p a -> p b -> p (Either a b) pEither p q = Left <$> p <|> Right <$> q --- | @<$$>@ is the version of @<$>@ which maps on its second argument +-- | `<$$>` is the version of `<$>` whichflips the function argument ---(<$$>) :: (a -> b -> c) -> P st b -> P st (a -> c)+(<$$>) :: IsParser p => (a -> b -> c) -> p b -> p (a -> c) f <$$> p = flip f <$> p --- | @<??>@ parses an optional postfix element and applies its result to its left hand result+-- | `<??>` parses an optional postfix element and applies its result to its left hand result ---(<??>) :: P st a -> P st (a -> a) -> P st a+(<??>) :: IsParser p => p a -> p (a -> a) -> p a p <??> q = must_be_non_empty "<??>" q (p <**> (q `opt` id)) --- | @`pPackes`@ surrounds its third parser with the first and the seond one, keeping only the middle result-pPacked :: P st b1 -> P st b2 -> P st a -> P st a+++infixl 4 <??>++-- | `pMany` is equivalent to the `many` from "Control.Applicative". We want however all our parsers to start with a lower case @p@.+pMany :: IsParser p => p a -> p [a]+pMany p = pList p++-- | `pSome` is equivalent to the `some` from "Control.Applicative". We want however all our parsers to start with a lower case @p@.+pSome :: (IsParser f) => f a -> f [a]+pSome p = (:) <$> p <*> pList p+++-- | @`pPacked`@ surrounds its third parser with the first and the second one, returning only the middle result+pPacked :: IsParser p => p b1 -> p b2 -> p a -> p a pPacked l r x = l *> x <* r --- * The collection of iterating combinators, all in a greedy (default) and a non-greedy variant+-- * Iterating combinators, all in a greedy (default) and a non-greedy (ending with @_ng@) variant -pFoldr :: (a -> a1 -> a1, a1) -> P st a -> P st a1+-- ** Recognising list like structures+pFoldr :: IsParser p => (a -> a1 -> a1, a1) -> p a -> p a1 pFoldr alg@(op,e) p = must_be_non_empty "pFoldr" p pfm where pfm = (op <$> p <*> pfm) `opt` e -pFoldr_ng :: (a -> a1 -> a1, a1) -> P st a -> P st a1+pFoldr_ng :: IsParser p => (a -> a1 -> a1, a1) -> p a -> p a1 pFoldr_ng alg@(op,e) p = must_be_non_empty "pFoldr_ng" p pfm where pfm = (op <$> p <*> pfm) <|> pure e -pFoldr1 :: (v -> b -> b, b) -> P st v -> P st b+pFoldr1 :: IsParser p => (v -> b -> b, b) -> p v -> p b pFoldr1 alg@(op,e) p = must_be_non_empty "pFoldr1" p (op <$> p <*> pFoldr alg p) -pFoldr1_ng :: (v -> b -> b, b) -> P st v -> P st b+pFoldr1_ng :: IsParser p => (v -> b -> b, b) -> p v -> p b pFoldr1_ng alg@(op,e) p = must_be_non_empty "pFoldr1_ng" p (op <$> p <*> pFoldr_ng alg p) -pFoldrSep :: (v -> b -> b, b) -> P st a -> P st v -> P st b++list_alg :: (a -> [a] -> [a], [a1])+list_alg = ((:), [])++pList :: IsParser p => p a -> p [a]+pList p = must_be_non_empty "pList" p (pFoldr list_alg p)+pList_ng :: IsParser p => p a -> p [a]+pList_ng p = must_be_non_empty "pList_ng" p (pFoldr_ng list_alg p)++pList1 :: IsParser p => p a -> p [a]+pList1 p = must_be_non_empty "pList" p (pFoldr1 list_alg p)+pList1_ng :: IsParser p => p a -> p [a]+pList1_ng p = must_be_non_empty "pList_ng" p (pFoldr1_ng list_alg p)++-- * Recognising list structures with separators++pFoldrSep :: IsParser p => (v -> b -> b, b) -> p a -> p v -> p b pFoldrSep alg@(op,e) sep p = must_be_non_empties "pFoldrSep" sep p (op <$> p <*> pFoldr alg sepp `opt` e) where sepp = sep *> p-pFoldrSep_ng :: (v -> b -> b, b) -> P st a -> P st v -> P st b+pFoldrSep_ng :: IsParser p => (v -> b -> b, b) -> p a -> p v -> p b pFoldrSep_ng alg@(op,e) sep p = must_be_non_empties "pFoldrSep" 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 :: IsParser p => (a -> b -> b, b) -> p a1 ->p a -> p b pFoldr1Sep alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep" sep p pfm where pfm = op <$> p <*> pFoldr alg (sep *> p)-pFoldr1Sep_ng :: (a -> b -> b, b) -> P st a1 ->P st a -> P st b+pFoldr1Sep_ng :: IsParser p => (a -> b -> b, b) -> p a1 ->p a -> p b pFoldr1Sep_ng alg@(op,e) sep p = must_be_non_empties "pFoldr1Sep_ng" 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 p = must_be_non_empty "pList" p (pFoldr list_alg p)-pList_ng :: P st a -> P st [a]-pList_ng p = must_be_non_empty "pList_ng" p (pFoldr_ng list_alg p)--pList1 :: P st a -> P st [a]-pList1 p = must_be_non_empty "pList" p (pFoldr1 list_alg p)-pList1_ng :: P st a -> P st [a]-pList1_ng p = must_be_non_empty "pList_ng" p (pFoldr1_ng list_alg p)---pListSep :: P st a1 -> P st a -> P st [a]+pListSep :: IsParser p => p a1 -> p a -> p [a] pListSep sep p = must_be_non_empties "pListSep" sep p (pFoldrSep list_alg sep p)-pListSep_ng :: P st a1 -> P st a -> P st [a]+pListSep_ng :: IsParser p => p a1 -> p a -> p [a] pListSep_ng sep p = must_be_non_empties "pListSep_ng" sep p pFoldrSep_ng list_alg sep p -pList1Sep :: P st a1 -> P st a -> P st [a]+pList1Sep :: IsParser p => p a1 -> p a -> p [a] pList1Sep s p = must_be_non_empties "pListSep" s p (pFoldr1Sep list_alg s p)-pList1Sep_ng :: P st a1 -> P st a -> P st [a]+pList1Sep_ng :: IsParser p => p a1 -> p a -> p [a] pList1Sep_ng s p = must_be_non_empties "pListSep_ng" s p (pFoldr1Sep_ng list_alg s p) -pChainr :: P st (c -> c -> c) -> P st c -> P st c+-- * Combinators for chained structures+-- ** Treating the operator as right associative+pChainr :: IsParser p => p (c -> c -> c) -> p c -> p c pChainr op x = must_be_non_empties "pChainr" op x r where r = x <??> (flip <$> op <*> r)-pChainr_ng :: P st (c -> c -> c) -> P st c -> P st c+pChainr_ng :: IsParser p => p (c -> c -> c) -> p c -> p c pChainr_ng op x = must_be_non_empties "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+-- ** Treating the operator as left associative+pChainl :: IsParser p => p (c -> c -> c) -> p c -> p c pChainl op x = must_be_non_empties "pChainl" op x (f <$> x <*> pList (flip <$> op <*> x)) where f x [] = x f x (func:rest) = f (func x) rest-pChainl_ng :: P st (c -> c -> c) -> P st c -> P st c+pChainl_ng :: IsParser p => p (c -> c -> c) -> p c -> p c pChainl_ng op x = must_be_non_empties "pChainl_ng" op x (f <$> x <*> pList_ng (flip <$> op <*> x)) where f x [] = x f x (func:rest) = f (func x) rest --- | Build a parser for each elemnt in its argument list and tries them all.-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 --instance MonadPlus (P st) where- mzero = pFail- mplus = (<|>)---- * Merging parsers--infixl 3 <||>-data Freq p = AtLeast Int p- | AtMost Int p- | Between Int Int p- | One p- | Many p- | Opt p- | Never p--instance Functor Freq where- fmap f (AtLeast n p) = AtLeast n (f p)- fmap f (AtMost n p) = AtMost n (f p)- fmap f (Between n m p) = Between n m (f p)- fmap f (One p) = One (f p)- fmap f (Many p) = Many (f p)- fmap f (Opt p) = Opt (f p)- fmap f (Never p) = Never (f p)--canBeEmpty :: Freq t -> Bool-canBeEmpty (AtLeast _ p) = False-canBeEmpty (AtMost _ p) = True-canBeEmpty (Between n m p) = if n==0 then error "wrong use of Between" else False -- safety check-canBeEmpty (One p) = False-canBeEmpty (Many p) = True-canBeEmpty (Opt p) = True-canBeEmpty (Never p) = True--split :: [Freq p] -> ([Freq p] -> [Freq p]) -> [(p, [Freq p])]-split [] _ = []-split (x:xs) f = oneAlt (x, f xs): split xs (f.(x:))- where oneAlt (AtLeast 1 p, others) = (p, Many p : others)- oneAlt (AtLeast n p, others) = (p, AtLeast (n-1) p : others)- oneAlt (AtMost 1 p, others) = (p, others)- oneAlt (AtMost n p, others) = (p, AtMost (n-1) p : others)- oneAlt (Between 1 1 p, others) = (p, others)- oneAlt (Between 1 m p, others) = (p, AtMost (m-1) p : others)- oneAlt (Between n m p, others) = (p, Between (n-1) (m-1) p : others)- oneAlt (One p, others) = (p, others)- 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---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--newtype MergeSpec p = MergeSpec p--(<||>) :: MergeSpec (d, [Freq (P st (d -> d) )], e -> d -> g) - -> MergeSpec (i, [Freq (P st (i -> i) )], g -> i -> k) - -> MergeSpec ((d,i), [Freq (P st ((d,i) -> (d,i)))], e -> (d,i) -> k)--MergeSpec (pe, pp, punp) <||> MergeSpec (qe, qp, qunp)- = MergeSpec ( (pe, qe)- , map (fmap (mapFst <$>)) pp ++ map (fmap (mapSnd <$>)) qp- , \f (x, y) -> qunp (punp f x) y- )--pSem :: t -> MergeSpec (t1, t2, t -> t3 -> t4)- -> MergeSpec (t1, t2, (t4 -> t5) -> t3 -> t5)-f `pSem` MergeSpec (units, alts, unp) = MergeSpec (units, alts, \ g arg -> g ( unp f arg))--pMerge :: c -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e-sem `pMerge` MergeSpec (units, alts, unp) = unp sem <$> toParser alts (pure units)--pMergeSep :: (c, P st a) -> MergeSpec (d, [Freq (P st (d -> d))], c -> d -> e) -> P st e-(sem, sep) `pMergeSep` MergeSpec (units, alts, unp) = unp sem <$> toParserSep alts sep (pure units)--pBetween :: Int -> Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)-pBetween n m p = must_be_non_empty "pOpt" p - (if m <n || m <= 0 then (MergeSpec ([] ,[ ], id)) - else if n==0 then (MergeSpec ([] ,[AtMost m ((:) <$> p)], id)) - else (MergeSpec ([] ,[Between n m ((:) <$> p)], id)))--pAtMost :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)-pAtMost n p = must_be_non_empty "pOpt" p- (if n <= 0 then (MergeSpec ([] ,[ ], id))- else (MergeSpec ([] ,[AtMost n ((:) <$> p)], id)))+-- * Repeating parsers -pAtLeast :: Int -> P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)-pAtLeast n p = must_be_non_empty "pOpt" p- (if n <= 0 then (MergeSpec ([] ,[Many ((:) <$> p)], id))- else (MergeSpec ([] ,[AtLeast n ((:) <$> p)], id)))+-- | `pExact` recocgnises a specified number of elements+pExact :: (IsParser f) => Int -> f a -> f [a]+pExact n p | n == 0 = pure []+ | n > 0 = (:) <$> p <*> pExact (n-1) p -pMany :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)-pMany p = must_be_non_empty "pMany" p (MergeSpec ([] ,[Many ((:) <$> p)], id))+pBetween :: (IsParser f) => Int -> Int -> f a -> f [a]+pBetween m n p | n < 0 || m <0 = error "negative arguments to pBwteeen"+ | m > n = empty+ | otherwise = (++) <$> pExact m p <*> pAtMost (n-m) p -pOpt :: P t t1 -> t11 -> MergeSpec (t11, [Freq (P t (b -> t1))], a -> a)-pOpt p v = must_be_non_empty "pOpt" p (MergeSpec (v ,[Opt (const <$> p)], id))+pAtLeast :: (IsParser f) => Int -> f a -> f [a]+pAtLeast n p = (++) <$> pExact n p <*> pList p -pSome :: P t t1 -> MergeSpec ([a], [Freq (P t ([t1] -> [t1]))], a1 -> a1)-pSome p = must_be_non_empty "pSome" p (MergeSpec ([] ,[AtLeast 1 ((:) <$> p)], id))+pAtMost :: (IsParser f) => Int -> f a -> f [a]+pAtMost n p | n > 0 = (:) <$> p <*> pAtMost (n-1) p `opt` []+ | n == 0 = pure [] -pOne :: P t t1 -> MergeSpec (a, [Freq (P t (b -> t1))], a1 -> a1)-pOne p = must_be_non_empty "pOne" p (MergeSpec (undefined,[One (const <$> p)], id))+-- * Counting Parser+-- | Count the number of times @p@ has succeeded+pCount :: (IsParser p, Num b) => p a -> p b+pCount p = (\_ b -> b+1) <$> p <*> pCount p `opt` 0 -mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)-mapFst f (a, b) = (f a, b)+-- * Miscelleneous +-- | Build a parser for each element in the argument list and try them all.+pAny :: IsParser p => (a -> p a1) -> [a] -> p a1+pAny f l = foldr (<|>) pFail (map f l) -mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)-mapSnd f (a, b) = (a, f b)+-- | pSym was removed because the class Provides was eliminated+-- pAnySym :: Provides st s s => [s] -> P st s+-- pAnySym = pAny pSym
− src/Text/ParserCombinators/UU/Examples.hs
@@ -1,383 +0,0 @@-{-# OPTIONS_HADDOCK ignore-exports #-}-{-# LANGUAGE FlexibleInstances,- TypeSynonymInstances,- MultiParamTypeClasses,- CPP #-}---- | This module contains a lot of examples of the typical use of our parser combinator library. --- We strongly encourage you to take a look at the source code--- At the end you find a @`main`@ function which demonstrates the main characteristics. --- Only the @`run`@ function is exported since it may come in handy elsewhere.--module Text.ParserCombinators.UU.Examples (run, demo) where-import Data.Char-import Text.ParserCombinators.UU.Core-import Text.ParserCombinators.UU.BasicInstances-import Text.ParserCombinators.UU.Derived-import System.IO-import GHC.IO.Handle.Types---- import Control.Monad---- | The fuction @`run`@ runs the parser and shows both the result, and the correcting steps which were taken during the parsing process.-run :: Show t => Parser t -> String -> IO ()-run p inp = do let r@(a, errors) = parse ( (,) <$> p <*> pEnd) (listToStr inp (0,0))- putStrLn "--"- putStrLn ("-- > Result: " ++ show a)- if null errors then return ()- else do putStr ("-- > Correcting steps: \n")- show_errors errors- putStrLn "-- "----- | Our first two parsers are simple; one recognises a single 'a' character and the other one a single 'b'. Since we will use them later we --- convert the recognsied character into String so they can be easily combined.-pa ::Parser String -pa = lift <$> pSym 'a'-pb :: Parser String -pb = lift <$> pSym 'b'-pc :: Parser String -pc = lift <$> pSym 'c'-lift a = [a]---- | We can now run the parser @`pa`@ on input \"a\", which succeeds:------ > run pa "a" ------ > Result: "a"-----test1 = run pa "a"---- | If we run the parser @`pa`@ on the empty input \"\", the expected symbol in inserted, --- that the position where it was inserted is reported, and--- we get information about what was expected at that position: ------ > run pa ""------ > Result: "a"--- > Correcting steps: --- > Inserted 'a' at position 0 expecting 'a'--- --test2 = run pa ""---- | Now let's see what happens if we encounter an unexpected symbol, as in:------ > run pa "b"------ > Result: "a"--- > Correcting steps: --- > Deleted 'b' at position 0 expecting 'a'--- > Inserted 'a' at position 1 expecting 'a'--- --test3 = run pa "b"---- | The combinator @`<++>`@ applies two parsers sequentially to the input and concatenates their results:------ > run (pa <++> pa) "aa"@:------ > Result: "aa"--- ---(<++>) :: Parser String -> Parser String -> Parser String-p <++> q = (++) <$> p <*> q-pa2 = pa <++> pa-pa3 = pa <++> pa2--test4 = run pa2 "aa"---- | The function @`pSym`@ is overloaded. The type of its argument determines how to interpret the argument. Thus far we have seen single characters, --- but we may pass ranges as well as argument: ------ > run (pList (pSym ('a','z'))) "doaitse"--------- > Result: "doaitse"--- --test5 = run (pList (pSym ('a','z'))) "doaitse"-paz = pList (pSym ('a', 'z'))---- | An even more general instance of @`pSym`@ takes a triple as argument: a predicate, --- a string indicating what is expected, --- and the value to insert if nothing can be recognised: --- --- > run (pSym (\t -> 'a' <= t && t <= 'z', "'a'..'z'", 'k')) "1"--------- > Result: 'k'--- > Correcting steps: --- > Deleted '1' at position 0 expecting 'a'..'z'--- > Inserted 'k' at position 1 expecting 'a'..'z'--- --test6 :: IO ()-test6 = run paz' "1"-paz' = pSym (\t -> 'a' <= t && t <= 'z', "'a'..'z'", 'k')---- | The parser `pCount` recognises a sequence of elements, throws away the results of the recognition process (@ \<$ @), and just returns the number of returned elements.--- The choice combinator @\<\<|>@ indicates that preference is to be given to the left alternative if it can make progress. This enables us to specify greedy strategies:------ > run (pCount pa) "aaaaa"------ > Result: 5--- --test7 :: IO ()-test7 = run (pCount pa) "aaaaa"-pCount p = (+1) <$ p <*> pCount p <<|> pReturn 0---- | The parsers are instance of the class Monad and hence we can use the --- result of a previous parser to construct a following one: ------ > run (do {l <- pCount pa; pExact l pb}) "aaacabbb"------ > Result: ["b","b","b","b"]--- > Correcting steps: --- > Deleted 'c' at position 3 expecting one of ['a', 'b']--- > Inserted 'b' at position 8 expecting 'b'--- --test8 :: IO ()-test8 = run (do {l <- pCount pa; pExact l pb}) "aaacabbb"-pExact 0 p = pReturn []-pExact n p = (:) <$> p <*> pExact (n-1) p----- | The function @`amb`@ converts an ambigous parser into one which returns all possible parses: ------ > run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaaaa"------ > Result: ["aaaaa","aaaaa"]--- -test9 :: IO ()-test9 = run (amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)) "aaaaa"---- | The applicative style makes it very easy to merge recognsition and computing a result. --- As an example we parse a sequence of nested well formed parentheses pairs and--- compute the maximum nesting depth with @`wfp`@: ------ > run wfp "((()))()(())" ------ > Result: 3--- --wfp :: Parser Int-wfp = max <$> pParens ((+1) <$> wfp) <*> wfp `opt` 0-test10 = run wfp "((()))()(())"---- | It is very easy to recognise infix expressions with any number of priorities and operators:------ > operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]--- > same_prio ops = msum [ op <$ pSym c | (c, op) <- ops]--- > expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators) -- ------ which we can call: ------ > run expr "15-3*5+2^5"------ > Result: 32------ Note that also here correction takes place: ------ > run expr "2 + + 3 5"------ > Result: 37--- > Correcting steps: --- > Deleted ' ' at position 1 expecting one of ['0'..'9', '^', '*', '-', '+']--- > Deleted ' ' at position 3 expecting one of ['(', '0'..'9']--- > Inserted '0' at position 4 expecting '0'..'9'--- > Deleted ' ' at position 5 expecting one of ['(', '0'..'9']--- > Deleted ' ' at position 7 expecting one of ['0'..'9', '^', '*', '-', '+']--- ---test11 = run expr "15-3*5"-expr :: Parser Int-operators = [[('+', (+)), ('-', (-))], [('*' , (*))], [('^', (^))]]-same_prio ops = foldr (<|>) empty [ op <$ pSym c | (c, op) <- ops]-expr = foldr pChainl ( pNatural <|> pParens expr) (map same_prio operators) ----- | A common case where ambiguity arises is when we e.g. want to recognise identifiers, --- but only those which are not keywords. --- The combinator `micro` inserts steps with a specfied cost in the result --- of the parser which can be used to disambiguate:------ > --- > ident :: Parser String--- > ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces--- > idents = pList1 ident--- > pKey keyw = pToken keyw `micro` 1 <* spaces--- > spaces :: Parser String--- > spaces = pMunch (==' ')--- > takes_second_alt = pList ident --- > \<|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e) --- > \<$ pKey "if" <*> pList_ng ident --- > \<* pKey "then" <*> pList_ng ident--- > \<* pKey "else" <*> pList_ng ident ------ A keyword is followed by a small cost @1@, which makes sure that --- identifiers which have a keyword as a prefix win over the keyword. Identifiers are however--- followed by a cost @2@, with as result that in this case the keyword wins. --- Note that a limitation of this approach is that keywords are only recognised as such when expected!--- --- > test13 = run takes_second_alt "if a then if else c"--- > test14 = run takes_second_alt "ifx a then if else c"--- --- with results for @test13@ and @test14@:------ > Result: ["IfThenElse","a","if","c"]--- > Result: ["ifx","a","then","if", "else","c"]--- ---- | A mistake which is made quite often is to construct a parser which can recognise a sequence of elements using one of the --- derived combinators (say @`pList`@), but where the argument parser can recognise the empty string. --- The derived combinators check whether this is the case and terminate the parsing process with an error message:------ > run (pList spaces) ""--- > Result: *** Exception: The combinator pList--- > requires that it's argument cannot recognise the empty string------ > run (pMaybe spaces) " "--- > Result: *** Exception: The combinator pMaybe--- > requires that it's argument cannot recognise the empty string---test16 :: IO ()-test16 = run (pList spaces) " "--ident = ((:) <$> pSym ('a','z') <*> pMunch (\x -> 'a' <= x && x <= 'z') `micro` 2) <* spaces-idents = pList1 ident--pKey keyw = pToken keyw `micro` 1 <* spaces-spaces :: Parser String-spaces = pMunch (`elem` " \n")- -takes_second_alt = pList ident - <|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e) - <$ pKey "if" <*> pList_ng ident - <* pKey "then" <*> pList_ng ident- <* pKey "else" <*> pList_ng ident -test13 = run takes_second_alt "if a then if else c"-test14 = run takes_second_alt "ifx a then if else c"----- | The function------ > munch = pMunch ( `elem` "^=*") ------ returns the longest prefix of the input obeying the predicate:------ > run munch "==^^**rest" ------ > Result: "==^^**"--- > Correcting steps: --- > The token 'r' was not consumed by the parsing process.--- > The token 'e' was not consumed by the parsing process.--- > The token 's' was not consumed by the parsing process.--- > The token 't' was not consumed by the parsing process.--- --munch :: Parser String-munch = pa *> pMunch ( `elem` "^=*") <* pb---- | The effect of the combinator `manytill` from Parsec can be achieved:------ > run simpleComment "<!--123$$-->abc"--- > Result: "123$$"--- > Correcting steps: --- > The token 'a' was not consumed by the parsing process.--- > The token 'b' was not consumed by the parsing process.--- > The token 'c' was not consumed by the parsing process.--- --pManyTill :: P st a -> P st b -> P st [a]-pManyTill p end = [] <$ end - <<|> - (:) <$> p <*> pManyTill p end-simpleComment = string "<!--" - *> - pManyTill pAscii (string "-->")---string :: String -> Parser String-string = pToken-- bracketing expressions-pParens p = pSym '(' *> p <* pSym ')'-pBracks p = pSym '[' *> p <* pSym ']'-pCurlys p = pSym '{' *> p <* pSym '}'---- parsing numbers--pDigitAsInt = digit2Int <$> pDigit -pNatural = foldl (\a b -> a * 10 + b ) 0 <$> pList1 pDigitAsInt-digit2Int a = ord a - ord '0'---- parsing letters and identifiers-pAscii = pSym (chr 0, chr 255)-pDigit = pSym ('0', '9')-pLower = pSym ('a','z')-pUpper = pSym ('A','Z')-pLetter = pUpper <|> pLower-pVarId = (:) <$> pLower <*> pList pIdChar-pConId = (:) <$> pUpper <*> pList pIdChar-pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"--pAnyToken :: [String] -> Parser String-pAnyToken = pAny pToken---- parsing two alternatives and returning both rsults-pIntList :: Parser [Int]-pIntList = pParens ((pSym ';') `pListSep` (read <$> pList1 (pSym ('0', '9'))))-parseIntString :: Parser [String]-parseIntString = pParens ((pSym ';') `pListSep` ( pList1 (pSym ('0', '9'))))--#define DEMO(p,i) demo "p" i p--justamessage = "justamessage"--main :: IO ()-main = do DEMO (pa, "a")- DEMO (pa, "b")- DEMO (((++) <$> pa <*> pa), "bbab")- DEMO (pa, "ba")- DEMO (pa, "aa")- DEMO ((do {l <- pCount pa; pExact l pb}), "aaacabbbb")- DEMO ((amb ( (++) <$> pa2 <*> pa3 <|> (++) <$> pa3 <*> pa2)), "aaaaa")- DEMO (paz, "ab1z7")- DEMO ((pa <|> pb <?> justamessage), "c")- DEMO ((amb (pEither parseIntString pIntList)), "(123;456;789)")- DEMO (munch, "a^=^**^^b")- demo_merge------ | For documentation of @`pMerge`@ and @`<||>`@ see the module "Text.ParserCombinators.UU.Merge". Here we just give a @deno_merge@, which--- should speak for itself. Make sure your parsers are not getting ambiguous. This soon gets very expensive.----demo_merge :: IO ()-demo_merge = do DEMO (((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pb)) , "abba") - DEMO (((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pb)) , "bba")- -- run ((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pa)) , "aaa") -- is ambiguous, and thus incorrect- DEMO ((amb ((,) `pMerge` (pBetween 2 3 pa <||> pBetween 1 2 pa))) , "aaa")- putStr "The 'a' at the right hand side can b any of the three 'a'-s in the input\n"- DEMO (((,) `pMerge` (pAtLeast 3 pa <||> pAtMost 3 pb)) , "aabbbb") - DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "abba") - DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "abba") - DEMO (((,) `pMerge` (pSome pa <||> pMany pb)) , "") - DEMO (((,) `pMerge` (pMany pb <||> pSome pc)) , "bcbc") - DEMO (((,) `pMerge` (pSome pb <||> pMany pc)) , "bcbc")- DEMO (((,,,) `pMerge` (pSome pa <||> pMany pb <||> pOne pc <||> pNatural `pOpt` 5)), "babc45" )- DEMO (((,) `pMerge` (pMany (pa <|> pb) <||> pSome pNatural)) , "1ab12aab14")- DEMO (( (,) `pMerge` ( ((++) `pSem` (pMany pa <||> pMany pb)) <||> pOne pc)) , "abcaaab")- DEMO (((((,), pc) `pMergeSep` (pMany pa <||> pMany pb))) , "acbcacb")---demo :: Show r => String -> String -> Parser r -> IO ()-demo str input p= do putStr ("\n===========================================\n>> run " ++ str ++ " " ++ show input ++ "\n")- run p input--
+ src/Text/ParserCombinators/UU/Idioms.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE RankNTypes,+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ UndecidableInstances,+ FlexibleContexts,+ CPP #-}++module Text.ParserCombinators.UU.Idioms where++import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.BasicInstances+import Text.ParserCombinators.UU.Utils+import Text.ParserCombinators.UU.Demo.Examples hiding (show_demos)+import qualified Data.ListLike as LL+import Control.Applicative +++-- | The `Ii` is to be pronouunced as @stop@+data Ii = Ii ++-- | The function `iI` is to be pronouunced as @start@+iI :: Idiomatic (Str Char state loc) (a -> a) g => g+iI = idiomatic (pure id)++class Idiomatic st f g | g -> f st where+ idiomatic :: P st f -> g+instance Idiomatic (Str Char state loc) x (Ii -> P (Str Char state loc) x) where+ idiomatic ix Ii = ix+instance (Idiomatic (Str Char state loc) f g, IsLocationUpdatedBy loc Char, LL.ListLike state Char) + => Idiomatic (Str Char state loc) (a -> f) (P (Str Char state loc) a -> g) where+ idiomatic isf is = idiomatic (isf <*> is)+instance (Idiomatic (Str Char state loc) f g, IsLocationUpdatedBy loc Char, LL.ListLike state Char) + => Idiomatic (Str Char state loc) f (String -> g) where+ idiomatic isf str = idiomatic (isf <* pToken str)+instance (Idiomatic (Str Char state loc) f g, IsLocationUpdatedBy loc Char, LL.ListLike state Char) + => Idiomatic (Str Char state loc) f (Char -> g) where+ idiomatic isf c = idiomatic (isf <* pSym c)+instance Idiomatic st f g => Idiomatic st ((a -> b) -> f) ((a -> b) -> g) where+ idiomatic isf f = idiomatic (isf <*> (pure f))++-- | The idea of the Idiom concept is that sequential composition operators can be inferred from the type +-- of the various operands+--+-- >>> run (iI (+) '(' pNatural "+" pNatural ')' Ii) "(2+3"+-- Result: 5+-- Correcting steps: +-- Inserted ')' at position LineColPos 0 4 4 expecting one of [')', Whitespace, '0'..'9']+--+test :: Parser Int+test = iI (+) '(' pNatural "+" pNatural ')' Ii++#define DEMO(p,i) demo "p" i p++show_demos = demo "(iI (+) '(' pNatural \"+\" pNatural ')' Ii)::Parser Int" "(2+3)" ((iI (+) '(' pNatural "+" pNatural ')' Ii)::Parser Int)
+ src/Text/ParserCombinators/UU/MergeAndPermute.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | This module contains the additional data types, instance definitions and functions to run parsers in an interleaved way.+-- If all the interlevaed parsers recognise a single connected piece of the input text this incorporates the permutation parsers.+-- For some examples see the module "Text.ParserCombinators.UU.Demo.MergeAndpermute"++module Text.ParserCombinators.UU.MergeAndPermute where+import Text.ParserCombinators.UU.Core+import Control.Applicative++infixl 4 <||>, <<||> ++++-- * The data type `Gram`+-- | Since we want to get access to the individial parsers which recognise a consecutive piece of the input text we+-- define a new data type, which lifts the underlying parsers to the grammatical level, so they can be transformed, manipulated, and run in a piecewise way.+-- `Gram` is defined in such a way that we can always access the first parsers to be ran from such a structure.+-- We require that all the `Alt`s do not recognise the empty string. These should be covered by the `Maybe` in the `Gram` constructor.+data Gram f a = Gram [Alt f a] (Maybe a) +data Alt f a = forall b . Seq (f b) (Gram f (b -> a)) + | forall b. Bind (f b) (b -> Gram f a)++instance (Show a) => Show (Gram f a) where+ show (Gram l ma) = "Gram " ++ show (length l) ++ " " ++ show ma ++-- | The function `mkGram` splits a simple parser into the possibly empty part and the non-empty part.+-- The non-empty part recognises a consecutive part of the input.+-- Here we use the function `getOneP` and `getZeroP` which are provided in the uu-parsinglib package,+-- but they could easily be provided by other packages too.++mkGram :: P t a -> Gram (P t) a+mkGram p = case getOneP p of+ Just p -> Gram [p `Seq` Gram [] (Just id)] (getZeroP p)+ Nothing -> Gram [] (getZeroP p)++-- * Class instances for Gram+-- | We define instances for the data type `Gram` for `Functor`, `Applicative`, `Alternative` and `ExtAlternative`+instance Functor f => Functor (Gram f) where+ fmap f (Gram alts e) = Gram (map (f <$>) alts) (f <$> e)++instance Functor f => Functor (Alt f) where+ fmap a2c (fb `Seq` fb2a) = fb `Seq` ( (a2c .) <$> fb2a)+ fmap a2c (fb `Bind` b2fa) = fb `Bind` (\b -> fmap a2c (b2fa b))++-- | The left hand side operand is gradually transformed so we get access to its first component+instance Functor f => Applicative (Gram f) where+ pure a = Gram [] (Just a)+ Gram l le <*> ~rg@(Gram r re) + = Gram ((map (`fwdby` rg) l) ++ maybe [] (\e -> map (e <$>) r) le) (le <*> re)+ where (fb `Seq` fb2c2a) `fwdby` fc = fb `Seq` (flip <$> fb2c2a <*> fc)+ (fb `Bind` b2fc2a) `fwdby` fc = fb `Bind` ((<*> fc) . b2fc2a)++instance Functor f => Alternative (Gram f) where+ empty = Gram [] Nothing+ Gram ps pe <|> Gram qs qe = Gram (ps++qs) (pe <|> qe)++instance Functor f => ExtAlternative (Gram f) where+ p <<|> q = p <|> q+ p <?> s = error "No <?> defined for Grammars yet. If you need ask for it"+ must_be_non_empty msg (Gram _ (Just _)) _+ = error ("The combinator " ++ msg ++ " requires that it's argument cannot recognise the empty string\n")+ must_be_non_empty _ _ q = q+ must_be_non_empties msg (Gram _ (Just _)) (Gram _ (Just _)) _ + = error ("The combinator " ++ msg ++ " requires that not both arguments can recognise the empty string\n")+ must_be_non_empties msg _ _ q = q+++-- * `Gram` is a `Monad`+instance Monad (Gram f) where+ return a = Gram [] (Just a)+ Gram ps pe >>= a2qs = + let bindto :: Alt f b -> (b -> Gram f a) -> Alt f a+ (b `Seq` b2a) `bindto` a2c = b `Bind` (\b -> b2a >>= ((\b2a -> a2c (b2a b))))+ (b `Bind` b2a) `bindto` a2c = b `Bind` (\b -> b2a b >>= a2c)+ psa2qs = (map (`bindto` a2qs) ps)+ in case pe of+ Nothing -> Gram psa2qs Nothing+ Just a -> let Gram qs qe = a2qs a+ in Gram (psa2qs ++ qs) qe++instance Functor f => IsParser (Gram f)+ +-- | The function `<||>` is the merging equivalent of `<*>`. Instead of running its two arguments consecutively, +-- the input is split into parts which serve as input for the left operand and parts which are served to the right operand. +(<||>):: Functor f => Gram f (b->a) -> Gram f b -> Gram f a+pg@(Gram pl pe) <||> qg@(Gram ql qe)+ = Gram ( [ p `Seq` (flip <$> pp <||> qg) | p `Seq` pp <- pl ]+ ++ [ q `Seq` ((.) <$> pg <||> qq) | q `Seq` qq <- ql ]+ ++ [ fc `Bind` (\c -> c2fb2a c <||> qg) | fc `Bind` c2fb2a <- pl]+ ++ [ fc `Bind` (\c -> pg <||> c2fb c) | fc `Bind` c2fb <- ql]+ ) (pe <*> qe) ++-- | The function `<<||>` is a special version of `<||>`, whch only starts a new instance of its right operand when the left operand cannot proceed.+-- This is used in the function pmMany, where we want to merge as many instances of its argument, but not more than that.+pg@(Gram pl pe) <<||> ~qg@(Gram ql qe)+ = Gram ( [ p `Seq` (flip <$> pp <||> qg)| p `Seq` pp <- pl]+ ) (pe <*> qe)+++-- | `mkPaserM` converts a `Gram`mar beack into a parser, which can subsequenly be run.+mkParserM :: (Monad f, Applicative f, ExtAlternative f) => Gram f a -> f a+mkParserM (Gram ls le) = foldr (\ p pp -> doNotInterpret p <|> pp) (maybe empty pure le) (map mkParserAlt ls)+ where mkParserAlt (p `Seq` pp) = p <**> mkParserM pp+ mkParserAlt (fc `Bind` c2fa) = fc >>= (mkParserM . c2fa)+ ++-- | `mkParserS` is like `mkParserM`, with the additional feature that we allow seprators between the components. Only useful in the permuting case.+mkParserS :: (Monad f, Applicative f, ExtAlternative f) => f b -> Gram f a -> f a+mkParserS sep (Gram ls le) = foldr (\ p pp -> doNotInterpret p <|> pp) (maybe empty pure le) (map mkParserAlt ls)+ where mkParserAlt (p `Seq` pp) = p <**> mkParserP sep pp+ mkParserAlt (fc `Bind` c2fa) = fc >>= (mkParserS sep . c2fa)+ mkParserP :: (Monad f, Applicative f, ExtAlternative f) => f b -> Gram f a -> f a+ mkParserP sep (Gram ls le) = foldr (\ p pp -> doNotInterpret p <|> pp) (maybe empty pure le) (map mkParserAlt ls)+ where mkParserAlt (p `Seq` pp) = sep *> p <**> mkParserP sep pp+ mkParserAlt (fc `Bind` c2fa) = fc >>= (mkParserP sep . c2fa)++-- | Run a sufficient number of @p@'s in a merged fashion, but not more than necessary!!+pmMany :: Functor f => Gram f a -> Gram f [a]+pmMany p = let pm = (:) <$> p <<||> pm <|> pure [] in pm+++
src/Text/ParserCombinators/UU/README.hs view
@@ -1,4 +1,4 @@--- | Tis module contains some background information about a completely new version of the Utrecht parser combinator library.+-- | This module contains some background information about a completely new version of the Utrecht parser combinator library. -- -- Background material --
+ src/Text/ParserCombinators/UU/Utils.hs view
@@ -0,0 +1,309 @@+-- | This module provides some higher-level types and infrastructure to make it easier to use.++{-# LANGUAGE PatternGuards, ScopedTypeVariables, NoMonomorphismRestriction,FlexibleInstances, FlexibleContexts, RankNTypes, ScopedTypeVariables #-}+-- {-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleContexts #-}++module Text.ParserCombinators.UU.Utils (+ -- * Single-char parsers+ pCR,+ pLF,+ pLower,+ pUpper,+ pLetter,+ pAscii,+ pDigit,+ pDigitAsNum,+ pAnySym,++ -- * Whitespace and comments (comments - not yet supported)+ pSpaces, -- This should not be used very often. In general+ -- you may want to use it to skip initial whitespace+ -- at the start of all input, but after that you+ -- should rely on Lexeme parsers to skip whitespace+ -- as needed. (This is the same as the strategy used+ -- by Parsec).++ -- * Lexeme parsers (as opposed to 'Raw' parsers)+ lexeme,+ pDot,+ pComma,+ pDQuote,+ pLParen,+ pRParen,+ pLBracket,+ pRBracket,+ pLBrace,+ pRBrace,+ pSymbol,++ -- * Raw parsers for numbers+ pNaturalRaw,+ pIntegerRaw,+ pDoubleRaw,++ -- * Lexeme parsers for numbers+ pNatural,+ pInteger,+ pDouble,+ pPercent,++ -- * Parsers for Enums+ pEnumRaw,+ pEnum,+ pEnumStrs,++ -- * Parenthesized parsers+ pParens,+ pBraces,+ pBrackets,+ listParser,+ tupleParser,+ pTuple,++ -- * Lexeme parsers for `Date`-s+ pDay,+ pDayMonthYear,++ -- * Lexeme parser for quoted `String`-s+ pParentheticalString,+ pQuotedString,++ -- * Read-compatability+ parserReadsPrec,+ + -- * Basic facility for runninga parser, getting at most a single error message+ execParser,+ runParser+)+where++import Data.Char+import Data.List+import Data.Time+import Text.ParserCombinators.UU.Core+import Text.ParserCombinators.UU.BasicInstances +import Text.ParserCombinators.UU.Derived+import Control.Applicative+import Text.Printf+import qualified Data.ListLike as LL++------------------------------------------------------------------------++-- Single Char parsers++pCR :: Parser Char+pCR = pSym '\r'++pLF :: Parser Char+pLF = pSym '\n'++pLower :: Parser Char+pLower = pRange ('a','z')++pUpper :: Parser Char+pUpper = pRange ('A','Z')++pLetter:: Parser Char+pLetter = pUpper <|> pLower++pAscii :: Parser Char+pAscii = pRange ('\000', '\254')++pDigit :: Parser Char+pDigit = pRange ('0','9')+++pDigitAsNum :: Num a => Parser a+pDigitAsNum =+ digit2Int <$> pDigit+ where+ digit2Int a = fromInteger $ toInteger $ ord a - ord '0'++pAnySym :: String -> Parser Char+pAnySym = pAny pSym++-- * Dealing with Whitespace+pSpaces :: Parser String+pSpaces = pList $ pAnySym " \r\n\t" <?> "Whitespace"++-- | Lexeme Parsers skip trailing whitespace (this terminology comes from Parsec)+lexeme :: ParserTrafo a a+lexeme p = p <* pSpaces++pDot, pComma, pDQuote, pLParen, pRParen, pLBracket, pRBracket, pLBrace, pRBrace :: Parser Char+pDot = lexeme $ pSym '.'+pComma = lexeme $ pSym ','+pDQuote = lexeme $ pSym '"'+pLParen = lexeme $ pSym '('+pRParen = lexeme $ pSym ')'+pLBracket = lexeme $ pSym '['+pRBracket = lexeme $ pSym ']'+pLBrace = lexeme $ pSym '{'+pRBrace = lexeme $ pSym '}'++pSymbol :: String -> Parser String+pSymbol = lexeme . pToken++-- * Parsers for Numbers+-- ** Raw (non lexeme) parsers+pNaturalRaw :: (Num a) => Parser a+pNaturalRaw = foldl (\a b -> a * 10 + b) 0 <$> pList1 pDigitAsNum <?> "Natural"++pIntegerRaw :: (Num a) => Parser a+pIntegerRaw = pSign <*> pNaturalRaw <?> "Integer"++pDoubleRaw :: (Read a) => Parser a+pDoubleRaw = read <$> pDoubleStr++pDoubleStr :: Parser [Char]+pDoubleStr = pOptSign <*> (pToken "Infinity" <|> pPlainDouble)+ <?> "Double (eg -3.4e-5)"+ where+ pPlainDouble = (++) <$> ((++) <$> pList1 pDigit <*> (pFraction `opt` [])) <*> pExponent+ pFraction = (:) <$> pSym '.' <*> pList1 pDigit+ pExponent = ((:) <$> pAnySym "eE" <*> (pOptSign <*> pList1 pDigit)) `opt` []+ pOptSign = ((('+':) <$ (pSym '+')) <|> (('-':) <$ (pSym '-'))) `opt` id++-- | NB - At present this is /not/ a lexeme parser, hence we don't+-- support @- 7.0@, @- 7@, @+ 7.0@ etc.+-- It's also currently private - ie local to this module.+pSign :: (Num a) => Parser (a -> a)+pSign = (id <$ (pSym '+')) <|> (negate <$ (pSym '-')) `opt` id++pPercentRaw ::Parser Double+pPercentRaw = (/ 100.0) . read <$> pDoubleStr <* pSym '%' <?> "Double%"++pPctOrDbl = pPercentRaw <|> pDoubleRaw++-- ** Lexeme Parsers for Numbers++pNatural :: Num a => Parser a+pNatural = lexeme pNaturalRaw++pInteger :: Num a => Parser a+pInteger = lexeme pIntegerRaw++pDouble :: Parser Double+pDouble = lexeme pDoubleRaw++pPercent :: Parser Double+pPercent = lexeme pPctOrDbl++-- * Parsers for Enums++pEnumRaw :: forall a . ((Enum a, Show a)=> Parser a)+pEnumRaw = foldr (\ c r -> c <$ pToken (show c) <|> r) pFail enumerated+ <?> (printf "Enum (eg %s or ... %s)" (show (head enumerated)) (show (last enumerated)))+ -- unless it is an empty data decl we will always have a head/last (even if the same)+ -- if it is empty, you cannot use it anyhow...+ where+ enumerated :: [a]+ enumerated = [toEnum 0..] +-- pToken :: Provides st s s => [s] -> P st [s]+-- pToken [] = pure []+-- pToken (a:as) = (:) <$> pSym a <*> pToken as++pEnum :: (Enum a, Show a) => Parser a+pEnum = lexeme pEnumRaw++pEnumStrs :: [String]-> Parser String+pEnumStrs xs = pAny (\t -> pSpaces *> pToken t <* pSpaces) xs <?> "enumerated value in " ++ show xs+++-- * Parenthesized structures+pParens :: ParserTrafo a a+pParens p = pLParen *> p <* pRParen++pBraces :: ParserTrafo a a+pBraces p = pLBrace *> p <* pRBrace++pBrackets :: ParserTrafo a a+pBrackets p = pLBracket *> p <* pRBracket++-- * Lists and tuples+-- | eg [1,2,3]+listParser :: ParserTrafo a [a]+listParser = pBrackets . pListSep pComma++-- | eg (1,2,3)+tupleParser :: ParserTrafo a [a]+tupleParser = pParens . pListSep pComma++pTuple :: (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => [P (Str Char state loc) a] -> P (Str Char state loc) [a]+pTuple [] = [] <$ pParens pSpaces+pTuple (p:ps) = pParens $ (:) <$> lexeme p <*> mapM ((pComma *>) . lexeme) ps++-- * Lexeme parsers for Dates++data Month = Jan | Feb | Mar | Apr | May | Jun | Jul | Aug | Sep | Oct | Nov | Dec+ deriving (Enum, Bounded, Eq, Show, Ord)++pDayMonthYear :: (Num d, Num y) => Parser (d, Int, y)+pDayMonthYear = lexeme $ (,,) <$> pDayNum <*> (pSym '-' *> pMonthNum) <*> (pSym '-' *> pYearNum)+ where+ pMonthNum = ((+1) . (fromEnum :: Month -> Int)) <$> pEnumRaw <?> "Month (eg Jan)"+ pDayNum = pNaturalRaw <?> "Day (1-31)"+ pYearNum = pNaturalRaw <?> "Year (eg 2019)"++pDay :: Parser Day+pDay = (\(d,m,y) -> fromGregorian y m d) <$> pDayMonthYear++-- * Quoted Strings++pParentheticalString :: Char -> Parser String++pParentheticalString d = lexeme $ pSym d *> pList pNonQuoteVChar <* pSym d+ where+ pNonQuoteVChar = pSatisfy (\c -> visibleChar c && c /= d) + (Insertion "Character in a string set off from main text by delimiter, e.g. double-quotes or comment token" 'y' 5)+ -- visibleChar :: Char -> Bool+ visibleChar c = '\032' <= c && c <= '\126'++pQuotedString :: Parser String+pQuotedString = pParentheticalString '"'++-- * Read-compatability++-- | Converts a UU Parser into a read-style one.+--+-- This is intended to facilitate migration from read-style+-- parsers to UU-based ones.+parserReadsPrec :: Parser a -> Int -> ReadS a+parserReadsPrec p _ s = [parse ((,) <$> p <*> pMunch (const True)) . createStr (0::Int) $ s]+++-- * Running parsers straightforwardly++-- | The lower-level interface. Returns all errors. +execParser :: Parser a -> String -> (a, [Error LineColPos])+execParser p = parse_h ((,) <$> p <*> pEnd) . createStr (LineColPos 0 0 0)++-- | The higher-level interface. (Calls 'error' with a simplified error). +-- Runs the parser; if the complete input is accepted without problems return the+-- result else fail with reporting unconsumed tokens+runParser :: String -> Parser a -> String -> a+runParser inputName p s | (a,b) <- execParser p s =+ if null b+ then a+ else error (printf "Failed parsing '%s' :\n%s\n" inputName (pruneError s b))+ -- We do 'pruneError' above because otherwise you can end+ -- up reporting huge correction streams, and that's+ -- generally not helpful... but the pruning does discard info...+ where -- | Produce a single simple, user-friendly error message+ pruneError :: String -> [Error LineColPos] -> String+ pruneError _ [] = ""+ pruneError _ (DeletedAtEnd x : _) = printf "Unexpected '%s' at end." x+ pruneError s (Inserted _ pos exp : _) = prettyError s exp pos+ pruneError s (Deleted _ pos exp : _) = prettyError s exp pos+ prettyError :: String -> [String] -> LineColPos -> String+ prettyError s exp p@(LineColPos line c abs) = printf "Expected %s at %s :\n%s\n%s\n%s\n"+ (show_expecting p exp)+ (show p)+ aboveString+ inputFrag+ belowString+ where+ s' = map (\c -> if c=='\n' || c=='\r' || c=='\t' then ' ' else c) s+ aboveString = replicate 30 ' ' ++ "v"+ belowString = replicate 30 ' ' ++ "^"+ inputFrag = replicate (30 - c) ' ' ++ (take 71 $ drop (c - 30) s')
uu-parsinglib.cabal view
@@ -1,5 +1,5 @@ Name: uu-parsinglib-Version: 2.5.6.1+Version: 2.7.0 Build-Type: Simple License: MIT Copyright: S Doaitse Swierstra @@ -9,34 +9,39 @@ Stability: stable, but evolving Homepage: http://www.cs.uu.nl/wiki/bin/view/HUT/ParserCombinators Bug-reports: mailto:doaitse@swierstra.net -Synopsis: Online, error-correcting parser combinators; monadic and applicative interfaces +Synopsis: Fast, online, error-correcting, monadic, applicative, merging, permuting, idiomatic parser combinators. Cabal-Version: >=1.4 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 interface.- Parsers do analyse themselves to avoid commonly made errors. A recent addition was the combinator @`pMerge`@ and - associates which generalises merging and permuting parsers.+ 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 generalises merging and permuting parsers. .- The module "Text.ParserCombinators.UU.Examples" contains a ready-made @main@ function,- which can be called to see e.g. the error correction at work. It contains haddock documentation; - try all the small tests for yourself to see the correction process at work, and to get a - feeling for how to use the various combinators. + This version is based on the module "Data.Listlike", and as a result a great variatey of input structures (@Strings@, @ByteStrings@, etc.) can be handled .- The file "Text.ParserCombinators.UU.Changelog" contains a log of the most recent changes and additions+ The modules "Text.ParserCombinators.UU.Demo.Examples", "Text.ParserCombinators.UU.Idioms" and "Text.ParserCombinators.UU.Demo.MergeAndpermute" + contain a ready-made @show_examples@ function,+ which can be called (e.g. from @ghci@) to see e.g. the error correction at work. It contains extensive haddock documentation, so why not just take a look to see the correction process at work, and to get a feeling for how the various combinators can be used. .+ The file "Text.ParserCombinators.UU.CHANGELOG" contains a log of the most recent changes and additions+ . The file "Text.ParserCombinators.UU.README" contains some references to background information .- We maintain a low frequency mailing for discussing the package. You can subscribe at: https://mail.cs.uu.nl/mailman/listinfo/parsing+ We maintain a low frequency mailing for discussing the package. You can subscribe at: <https://mail.cs.uu.nl/mailman/listinfo/parsing> Category: Parsing Text Library hs-source-dirs: src - Build-Depends: base >= 4.2 && <5, haskell98+ Build-Depends: base >= 4.2 && <5, time, ListLike >= 3.0.1+ Exposed-modules: Text.ParserCombinators.UU Text.ParserCombinators.UU.CHANGELOG Text.ParserCombinators.UU.README- Text.ParserCombinators.UU.Core + Text.ParserCombinators.UU.Core Text.ParserCombinators.UU.BasicInstances Text.ParserCombinators.UU.Derived- Text.ParserCombinators.UU.Examples-+ Text.ParserCombinators.UU.MergeAndPermute+ Text.ParserCombinators.UU.Utils+ Text.ParserCombinators.UU.Idioms+ Text.ParserCombinators.UU.Demo.Examples+ Text.ParserCombinators.UU.Demo.MergeAndPermute