gll 0.3.0.7 → 0.3.0.9

raw patch · 10 files changed

+359/−170 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.txt +11/−23
• gll.cabal +2/−1
• src/GLL/Combinators/Interface.hs +113/−119
• src/GLL/Combinators/Lexer.hs +5/−0
• src/GLL/Combinators/Options.hs +4/−1
• src/GLL/Combinators/Test/Interface.hs +87/−17
• src/GLL/Combinators/Visit/Join.hs +100/−0
• src/GLL/Combinators/Visit/Sem.hs +4/−4
• src/GLL/Parser.hs +6/−5
• src/GLL/Types/Abstract.hs +27/−0

@@ -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 <multiple/some/many>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 

@@ -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 

@@ -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 '"')

@@ -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 ((/=) '\'')

@@ -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

@@ -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<A" pX   [("aaa", ["aab"]),("aa", ["ab"])]++    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>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"]

@@ -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+

@@ -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)

@@ -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

@@ -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 _)          = "<bool>"     show (StringLit (Just s)) = "string(\"" ++ s ++ "\")"     show (StringLit _)        = "<string>"+    show (CharLit (Just c))   = "char-literal('" ++ [c] ++ "')"+    show (CharLit Nothing)    = "<char>"     show (AltIDLit (Just id)) = "altid(\"" ++ id ++ "\")"     show (AltIDLit Nothing)   = "<altid>"     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+          _                   -> ""