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 @@ -5,7 +5,8 @@ FlexibleInstances, FlexibleContexts, UndecidableInstances, - NoMonomorphismRestriction#-} + NoMonomorphismRestriction, + TypeSynonymInstances #-} -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% Some Instances %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -31,65 +32,82 @@ show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]" show_expecting [] = " expecting nothing" -data Str t = Str { input :: [t] - , msgs :: [Error Int ] - , pos :: !Int - , deleteOk :: !Bool} +data Str t loc = Str { input :: [t] + , msgs :: [Error loc ] + , pos :: loc + , deleteOk :: !Bool} -listToStr ls = Str ls [] 0 True +listToStr ls initloc = Str ls [] initloc True -instance (Show a) => Provides (Str a) (a -> Bool, String, a) a where +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) + +instance IsLocationUpdatedBy (Int,Int) String where + advance = foldl advance + +instance (Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) (a -> Bool, String, a) a where splitState (p, msg, a) k (Str tts msgs pos del_ok) = let ins exp = (5, k a (Str tts (msgs ++ [Inserted (show a) pos exp]) pos False)) del exp = (5, splitState (p,msg, a) k - (Str (tail tts) (msgs ++ [Deleted (show(head tts)) pos exp]) (pos+1) True )) + (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 Step 1 (k t (Str ts msgs (pos + 1) True)) + then Step 1 (k t (Str ts msgs (advance pos t) True)) else Fail [msg] (ins: if del_ok then [del] else []) [] -> Fail [msg] [ins] -instance (Ord a, Show a) => Provides (Str a) (a,a) a where +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) -instance (Eq a, Show a) => Provides (Str a) a a where +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) where +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 -instance Stores (Str a) (Error Int) where - getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok) +instance Stores (Str a loc) (Error loc) where + getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok) +instance HasPosition (Str a loc) loc where + getPos (Str inp msgs pos ok ) = pos + -- pMunch data Munch a = Munch (a -> Bool) -instance (Show a) => Provides (Str a) (Munch a) [a] where - splitState (Munch p) k (Str tts msgs pos del_ok) +instance (Show a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Munch a) [a] where + splitState (Munch p) k inp@(Str tts msgs pos del_ok) = let (munched, rest) = span p tts l = length munched - in Step l (k munched (Str rest msgs (pos+l) (l>0 || del_ok))) + in if l > 0 then Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok))) + else k [] inp pMunch :: (Provides st (Munch a) [a]) => (a -> Bool) -> P st [a] pMunch p = pSymExt Zero (Just []) (Munch p) data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token -instance (Show a, Eq a) => Provides (Str a) (Token a) [a] where +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 msg = show as in 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]) (pos+1) True )) + 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 -> Step l (k as (Str rest msgs (pos+l) True)) + Just rest -> Step l (k as (Str rest msgs (advance pos as) True)) pToken as = pTokenCost as 5 pTokenCost as c = if null as then error "call to pToken with empty token" diff --git a/src/Text/ParserCombinators/UU/CHANGELOG.hs b/src/Text/ParserCombinators/UU/CHANGELOG.hs --- a/src/Text/ParserCombinators/UU/CHANGELOG.hs +++ b/src/Text/ParserCombinators/UU/CHANGELOG.hs @@ -1,4 +1,18 @@ -- | This module just contains the CHANGELOG +-- Version 2.5.0 +-- +-- * generalised over the position in the input; now it is easy to maintain e.g. (line,column) info as shown in the "Examples.hs" file +-- +-- * added needed instances for @String@ s as input in "BasicInstances.hs" +-- +-- * fixed a bug in pMunch where a Step was inserted with 0 progress, leading to infinite insertions +-- +-- * added Haddock beautifications +-- +-- Version 2.4.5 +-- +-- * added the function @`pPos`@ for retreiving the current input position +-- -- Version 2.4.4 -- -- * solved a mistake which had crept in in the greedy choice 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 @@ -35,7 +35,13 @@ 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 +class loc `IsLocationUpdatedBy` a where + advance::loc -> a -> loc + -- * The type describing parsers: @`P`@ -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -94,6 +100,28 @@ Infinite Nothing +-- ** 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 comitted. Can be used to make parsers faster, and even +-- get a complete Parsec equivalent behaviour, with all its (dis)advantages. use with are! + +P ph pf pr pl pe <<|> P qh qf qr ql qe + = let (rl, b) = nat_min pl ql + bestx = if b then flip best else best + in P ( \ k st -> let left = norm (ph k st) + in if has_success left then left + else left `bestx` norm (qh k st)) + ( \ k st -> let left = norm (pf k st) + in if has_success left then left + else left `bestx` norm (qf k st)) + ( \ k st -> let left = norm (pr k st) + in if has_success left then left + else left `bestx` norm (qr k st)) + rl + (case (pe, qe) of + (Nothing, _ ) -> qe + (_ , Nothing) -> pe + (_ , _ ) -> error "ambiguous parser because two sides of choice can be empty") + -- ** 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. @@ -152,28 +180,7 @@ replaceExpected others = others --- ** 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 comitted. Can be used to make parsers faster, and even --- get a complete Parsec equivalent behaviour, with all its (dis)advantages. use with are! -P ph pf pr pl pe <<|> P qh qf qr ql qe - = let (rl, b) = nat_min pl ql - bestx = if b then flip best else best - in P ( \ k st -> let left = norm (ph k st) - in if has_success left then left - else left `bestx` norm (qh k st)) - ( \ k st -> let left = norm (pf k st) - in if has_success left then left - else left `bestx` norm (qf k st)) - ( \ k st -> let left = norm (pr k st) - in if has_success left then left - else left `bestx` norm (qr k st)) - rl - (case (pe, qe) of - (Nothing, _ ) -> qe - (_ , Nothing) -> pe - (_ , _ ) -> error "ambiguous parser because two sides of choice can be empty") - -- ** Parsers can be disambiguated using micro-steps: @`micro`@ -- | `micro` inserts a `Cost` step into the sequence representing the progress the parser is making; for its use see `Text.ParserCombinators.UU.Examples` P ph pf pr pl pe `micro` i = P ( \ k st -> ph (\ a st -> Micro i (k a st)) st) @@ -208,7 +215,21 @@ ( \ k inp -> let (errs, inp') = getErrors inp in push errs (k inp')) ( \ k inp -> let (errs, inp') = getErrors inp in k inp' ) Zero -- this parser does not consume input - (Just []) -- the errors consumed cannot be determined statically! Hence we assume none. + (Just (error "pErrors cannot occur in lhs of bind")) -- the errors consumed cannot be determined statically! + +-- ** The current position can be retreived from the state: @`pPos`@ +-- | `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 + +pPos :: HasPosition st pos => P st pos +pPos = P ( \ 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 ) + Zero -- this parser does not consume input + (Just (error "pPos cannot occur in lhs of bind")) -- the errors consumed cannot be determined statically! -- ** Starting and finalising the parsing process: @`pEnd`@ and @`parse`@ -- | The function `pEnd` should be called at the end of the parsing process. It deletes any unsonsumed input, and reports its preence as an eror. diff --git a/src/Text/ParserCombinators/UU/Examples.hs b/src/Text/ParserCombinators/UU/Examples.hs --- a/src/Text/ParserCombinators/UU/Examples.hs +++ b/src/Text/ParserCombinators/UU/Examples.hs @@ -1,4 +1,8 @@ {-# OPTIONS_HADDOCK ignore-exports #-} +{-# LANGUAGE FlexibleInstances, + TypeSynonymInstances, + MultiParamTypeClasses #-} + module Text.ParserCombinators.UU.Examples where import Char import Text.ParserCombinators.UU.Core @@ -7,13 +11,9 @@ import Text.ParserCombinators.UU.Merge import Control.Monad --- |We start out by defining the type of parser we want; by specifying the type of the state we resolve a lot of overloading - -type Parser a = P (Str Char) a - -- | 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 => P (Str Char) t -> String -> IO () -run p inp = do let r@(a, errors) = parse ( (,) <$> p <*> pEnd) (listToStr inp) +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 () @@ -245,7 +245,7 @@ pKey keyw = pToken keyw `micro` 1 <* spaces spaces :: Parser String -spaces = pMunch (==' ') +spaces = pMunch (`elem` " \n") takes_second_alt = pList ident <|> (\ c t e -> ["IfThenElse"] ++ c ++ t ++ e) 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.4.4 +Version: 2.5.0 Build-Type: Simple License: MIT Copyright: S Doaitse Swierstra