diff --git a/src/Text/ParserCombinators/UU.hs b/src/Text/ParserCombinators/UU.hs --- a/src/Text/ParserCombinators/UU.hs +++ b/src/Text/ParserCombinators/UU.hs @@ -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 + + + diff --git a/src/Text/ParserCombinators/UU/BasicInstances.hs b/src/Text/ParserCombinators/UU/BasicInstances.hs --- a/src/Text/ParserCombinators/UU/BasicInstances.hs +++ b/src/Text/ParserCombinators/UU/BasicInstances.hs @@ -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 diff --git a/src/Text/ParserCombinators/UU/CHANGELOG.hs b/src/Text/ParserCombinators/UU/CHANGELOG.hs --- a/src/Text/ParserCombinators/UU/CHANGELOG.hs +++ b/src/Text/ParserCombinators/UU/CHANGELOG.hs @@ -1,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 diff --git a/src/Text/ParserCombinators/UU/Core.hs b/src/Text/ParserCombinators/UU/Core.hs --- a/src/Text/ParserCombinators/UU/Core.hs +++ b/src/Text/ParserCombinators/UU/Core.hs @@ -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 - - - - - - diff --git a/src/Text/ParserCombinators/UU/Demo/Examples.hs b/src/Text/ParserCombinators/UU/Demo/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/UU/Demo/Examples.hs @@ -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 "") + + +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 diff --git a/src/Text/ParserCombinators/UU/Demo/MergeAndPermute.hs b/src/Text/ParserCombinators/UU/Demo/MergeAndPermute.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/UU/Demo/MergeAndPermute.hs @@ -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)) + + + + diff --git a/src/Text/ParserCombinators/UU/Derived.hs b/src/Text/ParserCombinators/UU/Derived.hs --- a/src/Text/ParserCombinators/UU/Derived.hs +++ b/src/Text/ParserCombinators/UU/Derived.hs @@ -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 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 diff --git a/src/Text/ParserCombinators/UU/Examples.hs b/src/Text/ParserCombinators/UU/Examples.hs deleted file mode 100644 --- a/src/Text/ParserCombinators/UU/Examples.hs +++ /dev/null @@ -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 "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 "") - - -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 - - diff --git a/src/Text/ParserCombinators/UU/Idioms.hs b/src/Text/ParserCombinators/UU/Idioms.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/UU/Idioms.hs @@ -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) diff --git a/src/Text/ParserCombinators/UU/MergeAndPermute.hs b/src/Text/ParserCombinators/UU/MergeAndPermute.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/UU/MergeAndPermute.hs @@ -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 + + + diff --git a/src/Text/ParserCombinators/UU/README.hs b/src/Text/ParserCombinators/UU/README.hs --- a/src/Text/ParserCombinators/UU/README.hs +++ b/src/Text/ParserCombinators/UU/README.hs @@ -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 -- diff --git a/src/Text/ParserCombinators/UU/Utils.hs b/src/Text/ParserCombinators/UU/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/UU/Utils.hs @@ -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') diff --git a/uu-parsinglib.cabal b/uu-parsinglib.cabal --- a/uu-parsinglib.cabal +++ b/uu-parsinglib.cabal @@ -1,5 +1,5 @@ Name: uu-parsinglib -Version: 2.5.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: 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