diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -1,23 +1,11 @@ -0.3.0.1 -> 0.3.0.2 - + smart constructors for creating Grammars. To be used instead of constructors. -0.3.0.2 -> 0.3.0.3 - + SubsumesToken class for making Token a subtype of a custom Parseable type. - The terminal parsers id_lit, int_lit, etc. can be used directly. - + Additional constructor in 'Token' for alternative identifiers. - - Method 'matches' of class 'Parseable' no longer has a default definition - (default was (==)). -0.3.0.3 -> 0.3.0.4 - + introduced lassoc, rassoc and assoc for associativity based - local disambiguation - + renamed some to many1 and let many and many1 implement shortest-match, - hence, if there is ambiguity the list with the maximum size is chosen. - + introduced some and some1 that are the same as many/many1 except - that they implement longest-match (resulting in minimum sized list) - + introduced multiple and multiple1 that are as above but implementing - no disambiguation (possibly useful for debuggin) - + introduced manySepBy(1), someSepBy(1) and multipleSepBy(1) -0.3.0.4 -> 0.3.0.6 - + added missing string literal token to predefined lexer - + added user-defined tokens to predefined lexer (given as a list) -0.3.0.6 -> 0.3.0.7 - + relaxed constraint on base +0.3.0.7 -> 0.3.0.8 + + export maximumPivots and maximumPivotAtNt +0.3.0.8 -> 0.3.0.9 + + include bit of the input string when showing an error message (without whitespace) + + exporting SepBy2 + + exporting within, parens, braces, brackets, angles, quotes and dquotes + + added character literals to Token type + + exporting <:= + + <<<**> and <**>>> for shortest and longest match, respectively + defined some/many and variants using <**>>> and <<<**> + disambiguation remains very experimental diff --git a/gll.cabal b/gll.cabal --- a/gll.cabal +++ b/gll.cabal @@ -3,7 +3,7 @@ -- The name of the package. name: gll -version: 0.3.0.7 +version: 0.3.0.9 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE @@ -59,6 +59,7 @@ , GLL.Types.Grammar , GLL.Combinators.Visit.Grammar , GLL.Combinators.Visit.Sem + , GLL.Combinators.Visit.Join extensions : TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances ghc-options: -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs --- a/src/GLL/Combinators/Interface.hs +++ b/src/GLL/Combinators/Interface.hs @@ -182,7 +182,7 @@ -- * Elementary parsers term_parser, satisfy, -- ** Elementary parsers using the 'Token' datatype - keychar, keyword, int_lit, bool_lit, string_lit, alt_id_lit, id_lit, token, + keychar, keyword, int_lit, bool_lit, char_lit, string_lit, alt_id_lit, id_lit, token, -- ** Elementary character-level parsers char, -- * Elementary combinators @@ -198,14 +198,15 @@ -- ** Grammar (combinator expression) types BNF, SymbExpr, AltExpr, AltExprs, -- ** Parseable token types - Token(..), Parseable(..), SubsumesToken(..), + Token(..), Parseable(..), SubsumesToken(..), unlexTokens, unlexToken, -- * Running a parser parse, -- ** Running a parser with options parseWithOptions, -- *** Possible options CombinatorOptions, CombinatorOption, - GLL.Combinators.Options.maximumErrors, throwErrors, + GLL.Combinators.Options.maximumErrors, throwErrors, + maximumPivot, maximumPivotAtNt, -- **** Parser options fullSPPF, allNodes, packedNodesOnly, strictBinarisation, -- *** Running a parser with options and explicit failure @@ -222,10 +223,13 @@ (<$$), (**>), (<**), -- *** EBNF patterns optional, multiple, multiple1, multipleSepBy, multipleSepBy1, + multipleSepBy2, within, parens, braces, brackets, angles, -- *** Disambiguation - (<::=), - lassoc, rassoc, assoc,many, many1, some, some1, - manySepBy, manySepBy1, someSepBy, someSepBy1, + (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>), + rassoc, lassoc, assoc, + many, many1, some, some1, + manySepBy, manySepBy1, manySepBy2, + someSepBy, someSepBy1,someSepBy2, -- * Lifting HasAlts(..), IsSymbExpr(..), IsAltExpr(..), -- * Memoisation @@ -233,17 +237,15 @@ ) where import GLL.Combinators.Options -import GLL.Combinators.Visit.Sem -import GLL.Combinators.Visit.Grammar +import GLL.Combinators.Visit.Join import GLL.Combinators.Memoisation import GLL.Combinators.Lexer import GLL.Types.Abstract import GLL.Parser hiding (parse, parseWithOptions, Options, Option, runOptions) import qualified GLL.Parser as GLL +import Control.Compose (OO(..)) import Control.Arrow -import Control.Compose (OO(..),unOO) -import Data.List (intercalate) import qualified Data.Array as A import qualified Data.IntMap as IM import qualified Data.Map as M @@ -251,24 +253,6 @@ import Data.IORef import System.IO.Unsafe --- | A combinator expression representing a symbol. --- A 'SymbExpr' either represents a terminal or a nonterminal. --- In the latter case it is constructed with (a variant of) '<:=>' and --- adds a rule to the grammar of which the represented symbol is the --- left-hand side. -data SymbExpr t a = SymbExpr (Symbol t, Grammar_Expr t, Sem_Symb t a) --- | A combinator expression representing a BNF-grammar. The terminals of --- the grammar are of type 't'. When used to parse, the expression yields --- semantic results of type 'a'. -type BNF t a = SymbExpr t a --- | --- A combinator expression representing an alternative: --- the right-hand side of a production. -data AltExpr t a = AltExpr ([Symbol t], Grammar_Expr t, Sem_Alt t a) - --- | A list of alternatives represents the right-hand side of a rule. -type AltExprs = OO [] AltExpr - parse' :: (Show t, Parseable t, IsSymbExpr s) => ParseOptions -> PCOptions -> s t a -> [t] -> (Grammar t, ParseResult t, Either String [a]) parse' popts opts p' input = @@ -347,26 +331,14 @@ (<::=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a x <::=> altPs = mkNtRule True False x altPs -mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> String -> b t a -> SymbExpr t a -mkNtRule use_ctx left_biased x' altPs' = - let vas1 = map (\(AltExpr (f,_,_)) -> f) altPs - vas2 = map (\(AltExpr (_,s,_)) -> s) altPs - vas3 = map (\(AltExpr (_,_,t)) -> t) altPs - alts = map (Prod x) vas1 - altPs = altsOf altPs' - x = pack x' - in SymbExpr (Nt x, grammar_nterm x alts vas2, sem_nterm use_ctx left_biased x alts vas3) - infixl 4 <$$> -- | -- Form an 'AltExpr' by mapping some semantic action overy the result -- of the second argument. (<$$>) :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b -f <$$> p' = - let SymbExpr (vpa1,vpa2,vpa3) = mkRule p' in AltExpr - ([vpa1],grammar_apply vpa2, sem_apply f vpa3) +f <$$> p' = join_apply f p' -infixl 4 <**> +infixl 4 <**>,<<<**>,<**>>> -- | -- Add a 'SymbExpr' to the right-hand side represented by an 'AltExpr' -- creating a new 'AltExpr'. @@ -374,11 +346,19 @@ -- as a cross-product. (<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t (a -> b) -> s t a -> AltExpr t b -pl' <**> pr' = - let AltExpr (vimp1,vimp2,vimp3) = toAlt pl' - SymbExpr (vpa1,vpa2,vpa3) = mkRule pr' in AltExpr - (vimp1++[vpa1], grammar_seq vimp2 vpa2, sem_seq vimp3 vpa3) +pl' <**> pr' = join_seq [] pl' pr' +-- | Variant of '<**>' that applies longest match on the left operand. +(<**>>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => + i t (a -> b) -> s t a -> AltExpr t b +pl' <**>>> pr' = join_seq [maximumPivot] pl' pr' + +-- | Variant of '<**>' that applies shortest match on the left operand. +(<<<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => + i t (a -> b) -> s t a -> AltExpr t b +pl' <<<**> pr' = join_seq [minimumPivot] pl' pr' + + infixr 3 <||> -- | -- Add an 'AltExpr' to a list of 'AltExpr' @@ -464,6 +444,13 @@ where unwrap (Just (BoolLit (Just b))) = b unwrap _ = error "bool_lit: downcast, or token without lexeme" +-- | Parse a single Character literal, using a 'SubsumesToken' type. +-- Returns the lexeme interpreted as a Character literal. +char_lit :: SubsumesToken t => SymbExpr t Char +char_lit = term_parser (upcast (CharLit Nothing)) (unwrap . downcast) + where unwrap (Just (CharLit (Just s))) = s + unwrap _ = error "char_lit: downcast, or token without lexeme" + -- | Parse a single String literal, using a 'SubsumesToken' type. -- Returns the lexeme interpreted as a String literal. string_lit :: SubsumesToken t => SymbExpr t String @@ -546,68 +533,89 @@ return $ map (id *** f) as ) -- | --- Version of '<$$>' that ignores the semantic result of its second argument. +-- Variant of '<$$>' that ignores the semantic result of its second argument. (<$$) :: (Show t, Ord t, IsSymbExpr s) => b -> s t a -> AltExpr t b f <$$ p = const f <$$> p infixl 4 <$$ -- | --- Version of '<**>' that ignores the semantic result of the first argument. +infixl 4 **>, <<**>, **>>> + +-- | +-- Variant of '<**>' that ignores the semantic result of the first argument. (**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b -l **>r = flip const .$. l <**> r -infixl 4 **> +l **> r = flip const .$. l <**> r +-- Variant of '<**>' that applies longest match on its left operand. +(**>>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b +l **>>> r = flip const .$. l <**>>> r + +-- Variant of '<**>' that ignores shortest match on its left operand. +(<<**>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t b +l <<**>r = flip const .$. l <<<**> r + + +infixl 4 <**, <<<**, <**>> -- | --- Version of '<**>' that ignores the semantic result of the second argument. +-- Variant of '<**>' that ignores the semantic result of the second argument. (<**) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a l <** r = const .$. l <**> r -infixl 4 <** +-- | Variant of '<**' that applies longest match on its left operand. +(<**>>) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a +l <**>> r = const .$. l <**>>> r + +-- | Variant '<**' that applies shortest match on its left operand +(<<<**) :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => i t a -> s t b -> AltExpr t a +l <<<** r = const .$. l <<<**> r + -- | --- Version of '<::=' that prioritises productions from left-to-right (or top-to-bottom). +-- Variant of '<::=>' that prioritises productions from left-to-right (or top-to-bottom). x <::= altPs = mkNtRule True True x altPs infixl 2 <::= --- | Try to apply a parser multiple times (0 or more). The results are returned in a list. --- In the case of ambiguity the largest list is returned. +-- | +-- Variant of '<:=>' that prioritises productions from left-to-right (or top-to-bottom). +x <:= altPs = mkNtRule False True x altPs +infixl 2 <:= + +-- | Try to apply a parser multiple times (0 or more) with shortest match +-- applied to each occurrence of the parser. many :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -many = multiple_ rassoc --- | Try to apply a parser multiple times (1 or more). The results are returned in a list. --- In the case of ambiguity the largest list is returned. +many = multiple_ (<<<**>) + +-- | Try to apply a parser multiple times (1 or more) with shortest match +-- applied to each occurrence of the parser. many1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -many1 = multiple1_ rassoc +many1 = multiple1_ (<<<**>) --- | Try to apply a parser multiple times (0 or more). The results are returned in a list. --- In the case of ambiguity the largest list is returned. +-- | Try to apply a parser multiple times (0 or more) with longest match +-- applied to each occurrence of the parser. some :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -some = multiple_ lassoc +some = multiple_ (<**>>>) --- | Try to apply a parser multiple times (1 or more). The results are returned in a list. --- In the case of ambiguity the largest list is returned. +-- | Try to apply a parser multiple times (1 or more) with longest match +-- applied to each occurrence of the parser. some1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -some1 = multiple1_ lassoc +some1 = multiple1_ (<**>>>) -- | Try to apply a parser multiple times (0 or more). The results are returned in a list. -- In the case of ambiguity the largest list is returned. multiple :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -multiple = multiple_ id +multiple = multiple_ (<**>) -- | Try to apply a parser multiple times (1 or more). The results are returned in a list. -- In the case of ambiguity the largest list is returned. multiple1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a] -multiple1 = multiple1_ id +multiple1 = multiple1_ (<**>) -- | Internal -multiple_ :: (Show t, Ord t, IsSymbExpr s) => (AltExpr t [a] -> AltExpr t [a]) -> - s t a -> SymbExpr t [a] multiple_ disa p = let fresh = mkNt p "*" - in fresh <::=> disa ((:) <$$> p <**> multiple p) <||> satisfy [] + in fresh <::=> ((:) <$$> p) `disa` (multiple_ disa p) <||> satisfy [] -- | Internal -multiple1_ :: (Show t, Ord t, IsSymbExpr s) => (AltExpr t [a] -> AltExpr t [a]) -> - s t a -> SymbExpr t [a] multiple1_ disa p = let fresh = mkNt p "+" - in fresh <::=> disa ((:) <$$> p <**> multiple p) + in fresh <::=> ((:) <$$> p) `disa` (multiple_ disa p) -- | Same as 'many' but with an additional separator. manySepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => @@ -642,55 +650,41 @@ (AltExpr t a -> SymbExpr t [a]) -> s1 t a -> s2 t b -> SymbExpr t [a] sepBy1 mult p c = mkRule $ (:) <$$> p <**> mult (c **> p) --- | Try to apply a parser once, but proceed if unsuccessful +-- | Like 'multipleSepBy1' but matching at least two occurrences of the +-- first argument. The returned list is therefore always of at least +-- length 2. At least one separator will be consumed. +multipleSepBy2 p s = mkRule $ + (:) <$$> p <** s <**> multipleSepBy1 p s + +-- | Like 'multipleSepBy2' but matching the minimum number of +-- occurrences of the first argument as possible (at least 2). +someSepBy2 p s = mkRule $ + (:) <$$> p <** s <**> someSepBy1 p s + +-- | Like 'multipleSepBy2' but matching the maximum number of +-- occurrences of the first argument as possible (at least 2). +manySepBy2 p s = mkRule $ + (:) <$$> p <** s <**> manySepBy1 p s + +-- | Make a piece of BNF optional, but proceed if unsuccessful -- (yielding 'Nothing' as a result in that case). optional :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) optional p = let fresh = mkNt p "?" in fresh <::=> Just <$$> p <||> satisfy Nothing --- | --- Class for lifting to 'SymbExpr'. -class IsSymbExpr a where - toSymb :: (Show t, Ord t) => a t b -> SymbExpr t b - -- | Synonym of 'toSymb' for creating /derived combinators/. - mkRule :: (Show t, Ord t) => a t b -> BNF t b - mkRule = toSymb - -instance IsSymbExpr AltExpr where - toSymb = toSymb . OO . (:[]) - -instance IsSymbExpr SymbExpr where - toSymb = id - -instance IsSymbExpr AltExprs where - toSymb a = mkName <:=> a - where mkName = "_toSb(" ++ intercalate ")|(" (map op (unOO a)) ++ ")_" - where op (AltExpr (rhs,_,_)) = "(" ++ intercalate ")*(" (map show rhs) ++ ")" --- | --- Class for lifting to 'AltExprs'. -class HasAlts a where - altsOf :: (Show t, Ord t) => a t b -> [AltExpr t b] - -instance HasAlts AltExpr where - altsOf = (:[]) - -instance HasAlts SymbExpr where - altsOf = altsOf . toAlt - -instance HasAlts AltExprs where - altsOf = unOO - --- | --- Class for lifting to 'AltExpr'. -class IsAltExpr a where - toAlt :: (Show t, Ord t) => a t b -> AltExpr t b - -instance IsAltExpr AltExpr where - toAlt = id - -instance IsAltExpr SymbExpr where - toAlt p = id <$$> p - -instance IsAltExpr AltExprs where - toAlt = toAlt . mkRule +-- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics. +within :: BNF Token a -> BNF Token b -> BNF Token c -> BNF Token b +within l p r = mkRule $ l **> p <** r +-- | Place a piece of BNF between the characters '(' and ')'. +parens p = within (keychar '(') p (keychar ')') +-- | Place a piece of BNF between the characters '{' and '}'. +braces p = within (keychar '{') p (keychar '}') +-- | Place a piece of BNF between the characters '[' and ']'. +brackets p = within (keychar '[') p (keychar ']') +-- | Place a piece of BNF between the characters '<' and '>'. +angles p = within (keychar '<') p (keychar '>') +-- | Place a piece of BNF between two single quotes. +quotes p = within (keychar '\'') p (keychar '\'') +-- | Place a piece of BNF between two double quotes. +dquotes p = within (keychar '"') p (keychar '"') diff --git a/src/GLL/Combinators/Lexer.hs b/src/GLL/Combinators/Lexer.hs --- a/src/GLL/Combinators/Lexer.hs +++ b/src/GLL/Combinators/Lexer.hs @@ -57,6 +57,7 @@ <|> charsToInt <$> optional (sym '-') <*> some (psym isDigit) <|> upcast . IDLit . Just <$> identifiers lexsets <|> upcast . AltIDLit . Just <$> altIdentifiers lexsets + <|> upcast . CharLit . Just <$> lCharLit <|> upcast . StringLit . Just <$> lStringLit <|> lMore where @@ -76,3 +77,7 @@ where strChar = sym '\\' *> sym '\"' <|> psym ((/=) '\"') toString inner = read ("\"" ++ inner ++ "\"") + + lCharLit = id <$ sym '\'' <*> charChar <* sym '\'' + where charChar = sym '\\' *> sym '\'' + <|> psym ((/=) '\'') diff --git a/src/GLL/Combinators/Options.hs b/src/GLL/Combinators/Options.hs --- a/src/GLL/Combinators/Options.hs +++ b/src/GLL/Combinators/Options.hs @@ -20,7 +20,10 @@ type CombinatorOption = PCOptions -> PCOptions runOptions :: CombinatorOptions -> PCOptions -runOptions = foldr ($) defaultOptions +runOptions = runOptionsOn defaultOptions + +runOptionsOn :: PCOptions -> CombinatorOptions -> PCOptions +runOptionsOn = foldr ($) -- | The default options: no disambiguation. defaultOptions :: PCOptions diff --git a/src/GLL/Combinators/Test/Interface.hs b/src/GLL/Combinators/Test/Interface.hs --- a/src/GLL/Combinators/Test/Interface.hs +++ b/src/GLL/Combinators/Test/Interface.hs @@ -36,7 +36,7 @@ import GLL.Combinators.Interface import GLL.Parseable.Char () --- | Defines and executes some unit-tests +-- | Defines and executes multiple1 unit-tests main = do count <- newIORef 1 let test mref name p arg_pairs = do @@ -110,29 +110,29 @@ test Nothing "inline choice (1)" pX [("ab", "b"), ("ac", "c"), ("a", []), ("b", [])] - let pX = "X" <::=> length <$$> many (char '1') - test Nothing "many" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])] + let pX = "X" <::=> length <$$> multiple (char '1') + test Nothing "multiple" pX [("", [0]), ("11", [2]), (replicate 12 '1', [12])] - let pX = "X" <::=> length <$$> some (char '1') - test Nothing "some" pX [("", []), ("11", [2]), (replicate 12 '1', [12])] + let pX = "X" <::=> length <$$> multiple1 (char '1') + test Nothing "multiple1" pX [("", []), ("11", [2]), (replicate 12 '1', [12])] - let pX = "X" <::=> 1 <$$ many (char 'a') <||> 2 <$$ many (char 'b') - test Nothing "(many <||> many) <**> optional" (pX <** optional (char 'z')) + let pX = "X" <::=> 1 <$$ multiple (char 'a') <||> 2 <$$ multiple (char 'b') + test Nothing "(multiple <||> multiple) <**> optional" (pX <** optional (char 'z')) [("az", [1]), ("bz", [2]), ("z", [1,2]) ,("", [1,2]), ("b", [2]), ("a", [1])] let pX = "X" <::=> pY <** optional (char 'z') - where pY = "Y" <::=> length <$$> many (char 'a') - <||> length <$$> some (char 'b') <** char 'e' - test Nothing "many & some & optional" + where pY = "Y" <::=> length <$$> multiple (char 'a') + <||> length <$$> multiple1 (char 'b') <** char 'e' + test Nothing "multiple & multiple1 & optional" pX [("aaaz", [3]), ("bbbez", [3]), ("ez", []), ("z", [0]) ,("aa", [2]), ("bbe", [2]) ] - -- many with nullable argument + -- multiple with nullable argument let pX = 1 <$$ char '1' <||> satisfy 0 - test Nothing "many (nullable arg)" - (many pX) [("11", [[1,1]]), ("",[[]]), ("e", [])] + test Nothing "multiple (nullable arg)" + (multiple pX) [("11", [[1,1]]), ("",[[]]), ("e", [])] -- Simple ambiguities let pX = (++) <$$> pA <**> pB @@ -148,10 +148,10 @@ <||> 4 <$$ char 'd' test Nothing "longambig" pX [("abcde", [[1,3],[2,4]]), ("abcdd", [])] - let pX = "X" <::=> (1 <$$ some (char 'a') <||> 2 <$$ many (char 'b')) + let pX = "X" <::=> (1 <$$ multiple1 (char 'a') <||> 2 <$$ multiple (char 'b')) pY = "Y" <::=> (+) <$$> pX <**> pY <||> satisfy 0 - test Nothing "some & many & recursion + ambiguities" pY + test Nothing "multiple1 & multiple & recursion + ambiguities" pY [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])] let pX = "X" <::=> 1 <$$ char 'a' <||> satisfy 0 @@ -201,10 +201,10 @@ putStrLn "Tests that use memoisation" let tab = newMemoTable - pX = "X" <::=> (1 <$$ some (char 'a') <||> 2 <$$ many (char 'b')) + pX = "X" <::=> (1 <$$ multiple1 (char 'a') <||> 2 <$$ multiple (char 'b')) pY = memo tab ("Y" <::=> (+) <$$> pX <**> pY <||> satisfy 0) - test (Just tab) "some & many & recursion + ambiguities" pY + test (Just tab) "multiple1 & multiple & recursion + ambiguities" pY [("ab", [3]),("aa", [1,2]), (replicate 10 'a', [1..10])] let tab = newMemoTable @@ -228,6 +228,76 @@ pY = memo tab ("Y" <::=> satisfy 0 <||> pX) test (Just tab) "hidden left-recursion + infinite derivations" pX [("", [0]), ("ab", [1]), ("ababab", [3])] + + putStrLn "Testing ambiguity reduction combinators" + let pX = (++) <$$> pA <**>>> pB + pA = "a" <$$ char 'a' <||> "aa" <$$ char 'a' <** char 'a' + pB = "b" <$$ char 'a' <||> "bb" <$$ char 'a' <** char 'a' + test Nothing "A pA <<<**> pB + pA = "a" <$$ char 'a' <||> "aa" <$$ char 'a' <** char 'a' + pB = "b" <$$ char 'a' <||> "bb" <$$ char 'a' <** char 'a' + test Nothing "A>A" pX [("aaa", ["abb"]),("aa", ["ab"])] + + let pX = "X" <:=> multiple pY + where pY = 1 <$$ char '1' <||> 2 <$$ char '1' <** char '1' + test Nothing "multiple" pX + [("", [[]]), ("1", [[1]]), ("11", [[1,1],[2]]), ("111", [[1,1,1], [2,1], [1,2]])] + + let pX = "X" <:=> some pY + where pY = 1 <$$ char '1' <||> 2 <$$ char '1' <** char '1' + test Nothing "some" pX + [("", [[]]), ("1", [[1]]), ("11", [[2]]), ("111", [[2,1]])] + +{- + -- a combinatar `fewest` (variant of multiple) should behave as follows + let pX = "X" <:=> fewest pY + where pY = 1 <$$ char '1' <||> 2 <$$ char '1' <** char '1' + test Nothing "some" pX + [("", [[]]), ("1", [[1]]), ("11", [[2]]), ("111", [[2,1], [1,2]])] +-} + + let pX = "X" <:=> many pY + where pY = 1 <$$ char '1' <||> 2 <$$ char '1' <** char '1' + test Nothing "many" pX + [("", [[]]), ("1", [[1]]), ("11", [[1,1]]), ("111", [[1,1,1]])] + + let pX = "X" <:=> "1" <$$ char '1' <||> multipleSepBy (char '1') (char ';') + test Nothing "multipleSepBy" pX + [("", [""]), ("1", ["1", "1"]), ("1;1", ["11"])] + + -- pX matches epsilon, therefore leading to infinitely many derivations + let pX :: BNF Char Int + pX = "X" <::=> 1 <$$ char '1' <||> sum <$$> multipleSepBy pX (char ';') + test Nothing "multipleSepBy2" pX + [("", [0]), ("1", [1,1]), ("1;1", [2]), (";1", [1]), (";1;1", [2])] + + let pX = "X" <:=> length <$$> multiple (char '1') + test Nothing "multiple1" pX + [("", [0]), ("11", [2]), (replicate 10 '1', [10])] + + let pX = "X" <:=> length <$$> multiple (char '1') <** char 'z' + test Nothing "multiple2" pX + [("", []), ("11z", [2]), (replicate 10 '1' ++ "z", [10])] + + let pX = "X" <:=> length <$$> multiple pEps <** char 'z' + where pEps = satisfy () <||> () <$$ char '1' + test Nothing "multiple & epsilon" pX + [("", []), ("z", [0])] + + let pX :: BNF Char Int + pX = "X" <::=> 1 <$$ char '1' <||> sum <$$> multipleSepBy pX (char ';') + test Nothing "multipleSepBy and multiple" (multiple pX) + -- why not ("", [[0]]) ?? + [("", [[]]), ("1", [[1],[1]]), ("1;1", [[1,0,1],[1,1],[2]]) + ,(";1;1", [[0,1,0,1],[0,1,1], [0,2], [1,0,1], [1,1], [2]])] +{- + let pX :: BNF Char Int + pX = "X" <::=> 1 <$$ char '1' <||> sum <$$> multipleSepBy pX (char ';') + test Nothing "manySepBy and multiple" (many pX) + -- why not ("", [[0]]) ?? + [("", [[]]), ("1", [[1],[1]]), ("1;1", [[1,0,1]])]-} where aho_S_5 = ["10101010100","10101011000","10101100100","10101101000","10101110000","10110010100","10110011000","10110100100","10110101000","10110110000","10111000100","10111001000","10111010000","10111100000","11001010100","11001011000","11001100100","11001101000","11001110000","11010010100","11010011000","11010100100","11010101000","11010110000","11011000100","11011001000","11011010000","11011100000","11100010100","11100011000","11100100100","11100101000","11100110000","11101000100","11101001000","11101010000","11101100000","11110000100","11110001000","11110010000","11110100000","11111000000"] diff --git a/src/GLL/Combinators/Visit/Join.hs b/src/GLL/Combinators/Visit/Join.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Visit/Join.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleInstances #-} + +module GLL.Combinators.Visit.Join where + +import GLL.Types.Grammar +import GLL.Types.Abstract +import GLL.Combinators.Visit.Sem +import GLL.Combinators.Visit.Grammar +import GLL.Combinators.Options + +import Control.Compose (OO(..),unOO) +import Data.List (intercalate) +import Data.Text (pack) + +-- | A combinator expression representing a symbol. +-- A 'SymbExpr' either represents a terminal or a nonterminal. +-- In the latter case it is constructed with (a variant of) '<:=>' and +-- adds a rule to the grammar of which the represented symbol is the +-- left-hand side. +data SymbExpr t a = SymbExpr (Symbol t, Grammar_Expr t, Sem_Symb t a) +-- | A combinator expression representing a BNF-grammar. The terminals of +-- the grammar are of type 't'. When used to parse, the expression yields +-- semantic results of type 'a'. +type BNF t a = SymbExpr t a +-- | +-- A combinator expression representing an alternative: +-- the right-hand side of a production. +data AltExpr t a = AltExpr ([Symbol t], Grammar_Expr t, Sem_Alt t a) + +-- | A list of alternatives represents the right-hand side of a rule. +type AltExprs = OO [] AltExpr + +mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> String -> b t a -> SymbExpr t a +mkNtRule use_ctx left_biased x' altPs' = + let vas1 = map (\(AltExpr (f,_,_)) -> f) altPs + vas2 = map (\(AltExpr (_,s,_)) -> s) altPs + vas3 = map (\(AltExpr (_,_,t)) -> t) altPs + alts = map (Prod x) vas1 + altPs = altsOf altPs' + x = pack x' + in SymbExpr (Nt x, grammar_nterm x alts vas2, sem_nterm use_ctx left_biased x alts vas3) + +join_apply :: (Show t, Ord t, IsSymbExpr s) => (a -> b) -> s t a -> AltExpr t b +join_apply f p' = + let SymbExpr (vpa1,vpa2,vpa3) = mkRule p' in AltExpr + ([vpa1],grammar_apply vpa2, sem_apply f vpa3) + +join_seq :: (Show t, Ord t, IsAltExpr i, IsSymbExpr s) => + CombinatorOptions -> i t (a -> b) -> s t a -> AltExpr t b +join_seq local_opts pl' pr' = + let AltExpr (vimp1,vimp2,vimp3) = toAlt pl' + SymbExpr (vpa1,vpa2,vpa3) = mkRule pr' in AltExpr + (vimp1++[vpa1], grammar_seq vimp2 vpa2, sem_seq local_opts vimp3 vpa3) + +-- | +-- Class for lifting to 'SymbExpr'. +class IsSymbExpr a where + toSymb :: (Show t, Ord t) => a t b -> SymbExpr t b + -- | Synonym of 'toSymb' for creating /derived combinators/. + mkRule :: (Show t, Ord t) => a t b -> BNF t b + mkRule = toSymb + +instance IsSymbExpr AltExpr where + toSymb = toSymb . OO . (:[]) + +instance IsSymbExpr SymbExpr where + toSymb = id + +instance IsSymbExpr AltExprs where + toSymb a = mkNtRule False False mkName a + where mkName = "_toSb(" ++ intercalate ")|(" (map op (unOO a)) ++ ")_" + where op (AltExpr (rhs,_,_)) = "(" ++ intercalate ")*(" (map show rhs) ++ ")" +-- | +-- Class for lifting to 'AltExprs'. +class HasAlts a where + altsOf :: (Show t, Ord t) => a t b -> [AltExpr t b] + +instance HasAlts AltExpr where + altsOf = (:[]) + +instance HasAlts SymbExpr where + altsOf = altsOf . toAlt + +instance HasAlts AltExprs where + altsOf = unOO + +-- | +-- Class for lifting to 'AltExpr'. +class IsAltExpr a where + toAlt :: (Show t, Ord t) => a t b -> AltExpr t b + +instance IsAltExpr AltExpr where + toAlt = id + +instance IsAltExpr SymbExpr where + toAlt p = join_apply id p + +instance IsAltExpr AltExprs where + toAlt = toAlt . mkRule + diff --git a/src/GLL/Combinators/Visit/Sem.hs b/src/GLL/Combinators/Visit/Sem.hs --- a/src/GLL/Combinators/Visit/Sem.hs +++ b/src/GLL/Combinators/Visit/Sem.hs @@ -44,14 +44,14 @@ in do as <- p opts ctx sppf arr l r return (maybe [] (const (map (op f) as)) $ sppf `pNodeLookup` ((alt,1),l,r)) -sem_seq :: Ord t => Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b -sem_seq p q opts (alt@(Prod x rhs),j) ctx sppf arr l r = +sem_seq :: Ord t => CombinatorOptions -> Sem_Alt t (a -> b) -> Sem_Symb t a -> Sem_Alt t b +sem_seq local_opts p q opts (alt@(Prod x rhs),j) ctx sppf arr l r = let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r) - choices = case pivot_select opts of + choices = case pivot_select (runOptionsOn opts local_opts) of Nothing -> ks Just compare -> maximumsWith compare ks seq k = do as <- q opts ctx sppf arr k r - a2bs <- p opts(alt,j-1) ctx sppf arr l k + a2bs <- p opts (alt,j-1) ctx sppf arr l k return [ (k,a2b a) | (_,a2b) <- a2bs, a <- as ] in do ass <- forM choices seq return (concat ass) diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs --- a/src/GLL/Parser.hs +++ b/src/GLL/Parser.hs @@ -530,7 +530,7 @@ , error_message :: String } -resultFromMutable :: (Show t, Ord t) => Input t -> Flags -> Mutable t -> SNode t -> ParseResult t +resultFromMutable :: Parseable t => Input t -> Flags -> Mutable t -> SNode t -> ParseResult t resultFromMutable inp flags mutable s_node@(s, l, m) = let u = mut_descriptors mutable gss = mut_gss mutable @@ -551,19 +551,20 @@ sppf@(sMap, iMap, pMap, eMap) = mut_sppf mutable in ParseResult sppf (mut_success mutable) usize s_nodes m i_nodes p_nodes sppf_edges gss_nodes gss_edges (renderErrors inp flags (mut_mismatches mutable)) -renderErrors :: Show t => Input t -> Flags -> MisMatches t -> String +renderErrors :: Parseable t => Input t -> Flags -> MisMatches t -> String renderErrors inp flags mm = render doc where n = max_errors flags locs = reverse (IM.assocs mm) doc = text ("Unsuccessful parse, showing "++ show n ++ " furthest matches") $+$ foldr (\loc -> (ppLoc loc $+$)) PP.empty locs - ppLoc (k, ts) = text ("did not match at position " ++ show k ++ ":") $+$ - nest 4 (text (show token)) $+$ + ppLoc (k, ts) = text ("did not match at position " ++ show k ++ ", where we find " ++ lexeme) $+$ + nest 4 (text "Found" <+> ppExp token) $+$ nest 4 (text "expected:") $+$ nest 8 (vcat (map ppExp (S.toList ts))) where token = inp A.! k - ppExp = text . show + lexeme = concatMap unlex (take 5 (drop k (A.elems inp))) + ppExp t = text (unlex t) <+> text "AKA" <+> text (show t) instance Show (ParseResult t) where show res | res_success res = result_string diff --git a/src/GLL/Types/Abstract.hs b/src/GLL/Types/Abstract.hs --- a/src/GLL/Types/Abstract.hs +++ b/src/GLL/Types/Abstract.hs @@ -57,6 +57,7 @@ | IntLit (Maybe Int) | BoolLit (Maybe Bool) | StringLit (Maybe String) + | CharLit (Maybe Char) | IDLit (Maybe String) -- | alternative identifiers, for example functions vs. constructors (as in Haskell). | AltIDLit (Maybe String) @@ -83,6 +84,11 @@ -- while the grammar tokens do not matches :: a -> a -> Bool + -- | This function pretty-prints the Parseable type by displaying its lexeme. + -- Default implementation is 'show', which should be replaced for prettier error messages. + unlex :: a -> String + unlex = show + -- | Class whose members are super-types of 'Token'. class SubsumesToken a where upcast :: Token -> a @@ -106,6 +112,8 @@ show (BoolLit _) = "" show (StringLit (Just s)) = "string(\"" ++ s ++ "\")" show (StringLit _) = "" + show (CharLit (Just c)) = "char-literal('" ++ [c] ++ "')" + show (CharLit Nothing) = "" show (AltIDLit (Just id)) = "altid(\"" ++ id ++ "\")" show (AltIDLit Nothing) = "" show (IDLit (Just id)) = "id(\"" ++ id ++ "\")" @@ -117,12 +125,15 @@ eos = EOS eps = Epsilon + unlex = unlexToken + Token k _ `matches` Token k' _ = k' == k Char c `matches` Char c' = c' == c Keyword k `matches` Keyword k' = k' == k EOS `matches` EOS = True Epsilon `matches` Epsilon = True StringLit _ `matches` StringLit _ = True + CharLit _ `matches` CharLit _ = True IntLit _ `matches` IntLit _ = True BoolLit _ `matches` BoolLit _ = True AltIDLit _ `matches` AltIDLit _ = True @@ -130,3 +141,19 @@ _ `matches` _ = False +-- | Pretty-prints a list of 'Token's as a concatenation of their lexemes. +unlexTokens :: [Token] -> String +unlexTokens = Prelude.concatMap unlexToken + +unlexToken :: Token -> String +unlexToken t = case t of + Char c -> [c] + Keyword s -> s + IntLit (Just i) -> show i + BoolLit (Just b) -> show b + StringLit (Just s) -> s + CharLit (Just c) -> [c] + AltIDLit (Just s) -> s + IDLit (Just s) -> s + Token _ (Just s) -> s + _ -> ""