gll 0.4.0.5 → 0.4.0.11
raw patch · 10 files changed
+624/−52 lines, 10 filesdep +random-stringsdep +time
Dependencies added: random-strings, time
Files
- changelog.txt +20/−0
- gll.cabal +4/−1
- src/GLL/Combinators/BinaryInterface.hs +353/−0
- src/GLL/Combinators/Interface.hs +142/−12
- src/GLL/Combinators/Lexer.hs +10/−5
- src/GLL/Combinators/Test/Interface.hs +23/−2
- src/GLL/Combinators/Visit/Join.hs +4/−2
- src/GLL/Combinators/Visit/Sem.hs +12/−12
- src/GLL/Parser.hs +55/−17
- src/GLL/Types/Grammar.hs +1/−1
changelog.txt view
@@ -42,3 +42,23 @@ 0.4.0.4 -> 0.4.0.5 + relaxed cabal version constraint++0.4.0.5 -> 0.4.0.6+ + generalised the definition of `within` combinator with respect to token type++0.4.0.6 -> 0.4.0.7+ + simplified Ridge's "parsing context" in the semantic phase++0.4.0.7 -> 0.4.0.8+ + unified usage of input in both parser and combinators, speeding up initialisation of large files+ + fixed 'noSelectTest' 'ParseOption'++0.4.0.8 -> 0.4.0.9+ + reinstated a "binarised version" of the interface + + count number of successes in ParseResult, not just True/False++0.4.0.9 -> 0.4.0.10+ + build expression grammars from operator tables++0.4.0.10 -> 0.4.0.11+ + integer literals are now by default considered as natural numbers only, the 'signed_int_lits' flag of 'LexerSettings' can be used to turn on signed integers, restoring the behaviour of previous versions
gll.cabal view
@@ -3,7 +3,7 @@ -- The name of the package. name: gll-version: 0.4.0.5+version: 0.4.0.11 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE@@ -47,7 +47,10 @@ , pretty , text , regex-applicative >= 0.3+ , time >= 1.8+ , random-strings >= 0.1.1.0 exposed-modules : GLL.Combinators.Interface+ , GLL.Combinators.BinaryInterface , GLL.Combinators , GLL.Combinators.Test.Interface , GLL.Combinators.Options
+ src/GLL/Combinators/BinaryInterface.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE TypeOperators, FlexibleInstances #-}++-- |+-- This module provides the same functions and combinators as "GLL.Combinators.Interface".+-- The only difference is that the combinators of this module construct only symbol expressions ('SymbExpr'/'BNF').+-- The combinators are therefore easier to use: they are just as freely combined but with simpler types and simpler type-errors.+-- However, the the underlying grammars are binarised, resulting in slower parsing.+module GLL.Combinators.BinaryInterface (+ -- * Elementary parsers+ term_parser, satisfy,+ -- ** Elementary parsers using the 'Token' datatype + keychar, keyword, int_lit, float_lit, bool_lit, char_lit, string_lit, alt_id_lit, id_lit, token,+ -- ** Elementary character-level parsers+ char, + -- * Elementary combinators+ -- *** Sequencing+ (<**>),+ -- *** Choice+ (<||>),+ -- *** Semantic actions+ (<$$>),+ -- *** Nonterminal introduction+ (<:=>),(<::=>),chooses,chooses_prec,+ -- * Types+ -- ** Grammar (combinator expression) types+ BNF, SymbExpr, toSymb, mkRule,+ -- ** Parseable token types + Token(..), Parseable(..), SubsumesToken(..), unlexTokens, unlexToken, + -- * Running a parser + parse, printParseData, evaluatorWithParseData,+ -- ** Running a parser with options+ parseWithOptions, parseWithParseOptions, printParseDataWithOptions, evaluatorWithParseDataAndOptions,printGrammarData,+ -- *** Possible options+ CombinatorOptions, CombinatorOption, + GLL.Combinators.Options.maximumErrors, throwErrors, + maximumPivot, maximumPivotAtNt, leftBiased,+ -- **** Parser options+ fullSPPF, allNodes, packedNodesOnly, strictBinarisation, + GLL.Parser.noSelectTest,+ -- *** Running a parser with options and explicit failure+ parseWithOptionsAndError, parseWithParseOptionsAndError,+ -- ** Runing a parser to obtain 'ParseResult'.+ parseResult, parseResultWithOptions,ParseResult(..),+ -- ** Builtin lexers.+ default_lexer, + -- *** Lexer settings+ lexer, LexerSettings(..), emptyLanguage,+ -- * Derived combinators+ mkNt, + -- *** Ignoring semantic results+ (<$$), (**>), (<**),+ -- *** EBNF patterns+ optional, preferably, reluctantly, optionalWithDef,+ multiple, multiple1, multipleSepBy, multipleSepBy1,+ multipleSepBy2, within, parens, braces, brackets, angles,+ -- *** Disambiguation + (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>),+ longest_match,shortest_match,+ many, many1, some, some1, + manySepBy, manySepBy1, manySepBy2, + someSepBy, someSepBy1,someSepBy2,+ -- * Memoisation+ memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation,+ module GLL.Combinators.Interface+ ) where++import GLL.Combinators.Interface hiding (within, (**>), (<**>), (<**), (<<<**>), (<<<**), (**>>>), (<**>>>), satisfy, (<||>), (<||), (||>), (<$$>), (<$$), (<:=>), (<:=),(<::=>), (<::=), mkNt, manySepBy, manySepBy1, manySepBy2, multiple, multipleSepBy, many, multipleSepBy1, multipleSepBy2, someSepBy, someSepBy1, someSepBy2, some, memo, some1, many1, multiple1, shortest_match, longest_match, (<**>>), (<<**>), angles, braces, brackets, parens, within, optional, optionalWithDef, preferably, reluctantly, chooses, chooses_prec)+import qualified GLL.Combinators.Interface as IF+import GLL.Combinators.Options+import GLL.Combinators.Visit.Join+import GLL.Combinators.Visit.Sem (emptyAncestors)+import GLL.Combinators.Memoisation+import GLL.Combinators.Lexer+import GLL.Types.Grammar+import GLL.Parser hiding (parse, parseWithOptions)+import qualified GLL.Parser as GLL++import Control.Compose (OO(..))+import Control.Arrow+import qualified Data.Array as A+import qualified Data.IntMap as IM+import qualified Data.Map as M+import Data.Text (pack)+import Data.IORef +import Data.Time.Clock+import System.IO.Unsafe+++infixl 2 <:=>+-- | +-- Form a rule by giving the name of the left-hand side of the new rule.+-- Use this combinator on recursive non-terminals.+(<:=>) :: (Show t, Ord t) => String -> BNF t a -> BNF t a +n <:=> p = n IF.<:=> p+infixl 2 <::=>++-- | +-- Variant of '<:=>' for recursive non-terminals that have a potentially infinite+-- number of derivations for some input string.+--+-- A non-terminal yields infinitely many derivations +-- if and only if it is left-recursive and would be+-- left-recursive if all the right-hand sides of the productions of the+-- grammar are reversed.+(<::=>) :: (Show t, Ord t) => String -> BNF t a -> BNF t a+n <::=> p = n IF.<::=> p++-- | Variant of '<::=>' that can be supplied with a list of alternates+chooses :: (Show t, Ord t) => String -> [BNF t a] -> BNF t a+chooses p alts = IF.chooses p alts ++-- | Variant of '<::=' that can be supplied with a list of alternates+chooses_prec :: (Show t, Ord t) => String -> [BNF t a] -> BNF t a+chooses_prec p alts = IF.chooses_prec p alts ++infixl 4 <$$>+-- |+-- Form an 'AltExpr' by mapping some semantic action overy the result+-- of the second argument.+(<$$>) :: (Show t, Ord t) => (a -> b) -> BNF t a -> BNF t b+f <$$> p' = IF.toSymb (f IF.<$$> p')++infixl 4 <**>,<<<**>,<**>>>+-- | +-- Add a 'SymbExpr' to the right-hand side represented by an 'AltExpr'+-- creating a new 'AltExpr'. +-- The semantic result of the first argument is applied to the second +-- as a cross-product. +(<**>) :: (Show t, Ord t) => BNF t (a -> b) -> BNF t a -> BNF t b+pl' <**> pr' = IF.toSymb (pl' IF.<**> pr')++-- | Variant of '<**>' that applies longest match on the left operand.+(<**>>>) :: (Show t, Ord t) => BNF t (a -> b) -> BNF t a -> BNF t b+pl' <**>>> pr' = IF.toSymb (pl' IF.<**>>> pr')++-- | Variant of '<**>' that applies shortest match on the left operand.+(<<<**>) :: (Show t, Ord t) => BNF t (a -> b) -> BNF t a -> BNF t b+pl' <<<**> pr' = IF.toSymb (pl' IF.<<<**> pr')++infixr 3 <||>+-- |+-- Add an 'AltExpr' to a list of 'AltExpr'+-- The resuling '[] :. AltExpr' forms the right-hand side of a rule.+(<||>) :: (Show t, Ord t) => BNF t a -> BNF t a -> BNF t a+l' <||> r' = IF.toSymb (l' IF.<||> r') ++-- |+-- Apply this combinator to an alternative to turn all underlying occurrences+-- of '<**>' (or variants) apply 'longest match'.+longest_match :: (Show t, Ord t) => BNF t a -> BNF t a+longest_match isalt = IF.toSymb (IF.longest_match isalt)++-- Apply this combinator to an alternative to turn all underlying occurrences+-- of '<**>' (or variants) apply 'shortest match'.+shortest_match :: (Show t, Ord t) => BNF t a -> BNF t a+shortest_match isalt = IF.toSymb (IF.shortest_match isalt)++-- | The empty right-hand side that yields its +-- first argument as a semantic result.+satisfy :: (Show t, Ord t ) => a -> BNF t a+satisfy a = IF.toSymb (IF.satisfy a)++-- | +-- This function memoises a parser, given:+--+-- * A 'MemoRef' pointing to a fresh 'MemoTable', created using 'newMemoTable'.+-- * The 'SymbExpr' to memoise.+--+-- Use 'memo' on those parsers that are expected to derive the same +-- substring multiple times. If the same combinator expression is used+-- to parse multiple times the 'MemoRef' needs to be cleared using 'memClear'.+--+-- 'memo' relies on 'unsafePerformIO' and is therefore potentially unsafe.+-- The option 'useMemoisation' enables memoisation.+-- It is off by default, even if 'memo' is used in a combinator expression.+memo :: (Ord t, Show t) => MemoRef [a] -> BNF t a -> BNF t a+memo ref p' = IF.memo ref p' +-- | +-- Helper function for defining new combinators.+-- Use 'mkNt' to form a new unique non-terminal name based on+-- the symbol of a given 'SymbExpr' and a 'String' that is unique to+-- the newly defined combinator.+mkNt :: (Show t, Ord t) => BNF t a -> String -> String +mkNt p str = IF.mkNt p str ++-- | +-- Variant of '<$$>' that ignores the semantic result of its second argument. +(<$$) :: (Show t, Ord t) => b -> BNF t a -> BNF t b+f <$$ p = const f <$$> p+infixl 4 <$$++-- | +infixl 4 **>, <<**>, **>>>++-- | +-- Variant of '<**>' that ignores the semantic result of the first argument.+(**>) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t b+l **> r = flip const <$$> l <**> r++-- Variant of '<**>' that applies longest match on its left operand. +(**>>>) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t b+l **>>> r = flip const <$$> l <**>>> r++-- Variant of '<**>' that ignores shortest match on its left operand.+(<<**>) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t b+l <<**>r = flip const <$$> l <<<**> r+++infixl 4 <**, <<<**, <**>>+-- | +-- Variant of '<**>' that ignores the semantic result of the second argument.+(<**) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t a+l <** r = const <$$> l <**> r ++-- | Variant of '<**' that applies longest match on its left operand.+(<**>>) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t a+l <**>> r = const <$$> l <**>>> r ++-- | Variant '<**' that applies shortest match on its left operand+(<<<**) :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t a+l <<<** r = const <$$> l <<<**> r ++-- | +-- Variant of '<::=>' that prioritises productions from left-to-right (or top-to-bottom).+x <::= altPs = x IF.<::= altPs+infixl 2 <::=++-- | +-- Variant of '<:=>' that prioritises productions from left-to-right (or top-to-bottom).+x <:= altPs = x IF.<:= 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) => BNF t a -> BNF t [a]+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) => BNF t a -> BNF t [a]+many1 = multiple1_ (<<<**>) ++-- | 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) => BNF t a -> BNF t [a]+some = multiple_ (<**>>>)++-- | 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) => BNF t a -> BNF t [a]+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) => BNF t a -> BNF t [a]+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) => BNF t a -> BNF t [a]+multiple1 = multiple1_ (<**>)++-- | Internal+multiple_ disa p = let fresh = mkNt p "*" + in fresh <::=> ((:) <$$> p) `disa` (multiple_ disa p) <||> satisfy []++-- | Internal+multiple1_ disa p = let fresh = mkNt p "+"+ in fresh <::=> ((:) <$$> p) `disa` (multiple_ disa p)++-- | Same as 'many' but with an additional separator.+manySepBy :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+manySepBy = sepBy many+-- | Same as 'many1' but with an additional separator.+manySepBy1 :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+manySepBy1 = sepBy1 many+-- | Same as 'some1' but with an additional separator.+someSepBy :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+someSepBy = sepBy some+-- | Same as 'some1' but with an additional separator.+someSepBy1 :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+someSepBy1 = sepBy1 some+-- | Same as 'multiple' but with an additional separator.+multipleSepBy :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+multipleSepBy = sepBy multiple +-- | Same as 'multiple1' but with an additional separator.+multipleSepBy1 :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t [a]+multipleSepBy1 = sepBy1 multiple ++sepBy :: (Show t, Ord t) => (BNF t a -> BNF t [a]) -> BNF t a -> BNF t b -> BNF t [a]+sepBy mult p c = mkRule $ satisfy [] <||> (:) <$$> p <**> mult (c **> p)++sepBy1 :: (Show t, Ord t) => (BNF t a -> BNF t [a]) -> BNF t a -> BNF t b -> BNF t [a]+sepBy1 mult p c = mkRule $ (:) <$$> p <**> mult (c **> p)++-- | 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++-- | Derive either from the given symbol or the empty string.+optional :: (Show t, Ord t) => BNF t a -> BNF t (Maybe a)+optional p = fresh + <:=> Just <$$> p + <||> satisfy Nothing + where fresh = mkNt p "?"++-- | Version of 'optional' that prefers to derive from the given symbol,+-- affects only nullable nonterminal symbols+preferably :: (Show t, Ord t) => BNF t a -> BNF t (Maybe a)+preferably p = fresh + <:= Just <$$> p + <||> satisfy Nothing + where fresh = mkNt p "?"++-- | Version of 'optional' that prefers to derive the empty string from +-- the given symbol, affects only nullable nonterminal symbols+reluctantly :: (Show t, Ord t) => BNF t a -> BNF t (Maybe a)+reluctantly p = fresh + <:= satisfy Nothing + <||> Just <$$> p+ where fresh = mkNt p "?"++optionalWithDef :: (Show t, Ord t) => BNF t a -> a -> BNF t a +optionalWithDef p def = mkNt p "?" <:=> id <$$> p <||> satisfy def++-- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics.+within :: (Show t, Ord t) => BNF t a -> BNF t b -> BNF t c -> BNF t b+within l p r = IF.toSymb (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 '"')
src/GLL/Combinators/Interface.hs view
@@ -200,13 +200,13 @@ -- ** Parseable token types Token(..), Parseable(..), SubsumesToken(..), unlexTokens, unlexToken, -- * Running a parser - parse, + parse, printParseData, evaluatorWithParseData, -- ** Running a parser with options- parseWithOptions, parseWithParseOptions,+ parseWithOptions, parseWithParseOptions, printParseDataWithOptions, evaluatorWithParseDataAndOptions, printGrammarData, -- *** Possible options CombinatorOptions, CombinatorOption, GLL.Combinators.Options.maximumErrors, throwErrors, - maximumPivot, maximumPivotAtNt,+ maximumPivot, maximumPivotAtNt,leftBiased, -- **** Parser options fullSPPF, allNodes, packedNodesOnly, strictBinarisation, GLL.Parser.noSelectTest,@@ -226,6 +226,9 @@ optional, preferably, reluctantly, optionalWithDef, multiple, multiple1, multipleSepBy, multipleSepBy1, multipleSepBy2, within, parens, braces, brackets, angles,+ foldr_multiple, foldr_multipleSepBy,+ -- *** Operator expressions+ fromOpTable, OpTable, Assoc(..), Fixity(..), -- *** Disambiguation (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>), longest_match,shortest_match,@@ -240,43 +243,136 @@ import GLL.Combinators.Options import GLL.Combinators.Visit.Join+import GLL.Combinators.Visit.Sem (emptyAncestors) import GLL.Combinators.Memoisation import GLL.Combinators.Lexer import GLL.Types.Grammar import GLL.Parser hiding (parse, parseWithOptions) import qualified GLL.Parser as GLL +import Control.Monad (when) import Control.Compose (OO(..)) import Control.Arrow import qualified Data.Array as A import qualified Data.IntMap as IM import qualified Data.Map as M+import qualified Data.Set as S import Data.Text (pack)+import qualified Data.Text import Data.IORef +import Data.Time.Clock import System.IO.Unsafe 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 = let SymbExpr (Nt start,vpa2,vpa3) = mkRule ("__Start" <:=> OO [id <$$> p'])- snode = (start, 0, m)- m = length input rules = vpa2 M.empty- as = vpa3 opts IM.empty sppf arr 0 m+ as = vpa3 opts emptyAncestors sppf arr 0 m grammar = (start, [ p | (_, alts) <- M.assocs rules, p <- alts ]) max_err = max_errors opts- parse_res = GLL.parseWithOptions (popts++[GLL.maximumErrors max_err]) grammar input+ parse_res = GLL.parseWithOptionsArray (popts++[GLL.maximumErrors max_err]) grammar arr sppf = sppf_result parse_res- arr = A.array (0,m) (zip [0..] input)+ arr = mkInput input + m = length input res_list = unsafePerformIO as in (grammar, parse_res, if res_success parse_res && not (null res_list) then Right $ res_list else Left (error_message parse_res) ) +-- | Print some information about the parse.+-- Helpful for debugging.+printParseData :: (Parseable t, IsSymbExpr s, Show a) => s t a -> [t] -> IO ()+printParseData = printParseDataWithOptions [] [] ++-- | Variant of 'printParseData' which can be controlled by 'ParseOption's+printParseDataWithOptions :: (Parseable t, IsSymbExpr s, Show a) => ParseOptions -> CombinatorOptions -> s t a -> [t] -> IO ()+printParseDataWithOptions popts opts p' input = + let SymbExpr (Nt start,vpa2,vpa3) = mkRule ("__Start" <:=> OO [id <$$> p'])+ rules = vpa2 M.empty+ grammar = (start, [ p | (_, alts) <- M.assocs rules, p <- alts ])+ parse_res = GLL.parseWithOptions (popts ++ [packedNodesOnly,strictBinarisation]) grammar input+ arr = mkInput input + (_,m) = A.bounds arr+ in do let (_,prods) = grammar+ nt_set = S.fromList [ x | Prod x _ <- prods ]+ putStrLn $ "#production: " ++ show (length prods)+ putStrLn $ "#nonterminals: " ++ show (length nt_set)+ putStrLn $ "largest nonterminal: " ++ show ( + foldr (\x -> max (Data.Text.length x)) 0 nt_set)++ startTime <- getCurrentTime+ putStrLn $ "#tokens: " ++ (show m)+ putStrLn $ "#successes: " ++ (show $ res_successes parse_res)+ endTime <- getCurrentTime+ putStrLn $ "recognition time: " ++ show (diffUTCTime endTime startTime)+ startTime' <- getCurrentTime+ putStrLn $ "#descriptors " ++ (show $ nr_descriptors parse_res)+ putStrLn $ "#EPNs " ++ (show $ nr_packed_node_attempts parse_res) + endTime <- getCurrentTime+ putStrLn $ "parse-data time: " ++ show (diffUTCTime endTime startTime')+{- startTime' <- getCurrentTime+ as <- vpa3 (runOptions opts) emptyAncestors (sppf_result parse_res) arr 0 m+ putStrLn $ "ambiguous?: " ++ show (length as > 1)+ when (not (null as)) (writeFile "/tmp/derivation" (show (head as)))+ endTime <- getCurrentTime+ putStrLn $ "semantic phase: " ++ show (diffUTCTime endTime startTime')-}+ putStrLn $ "total time: " ++ show (diffUTCTime endTime startTime)++-- | Print some information +evaluatorWithParseData :: (Parseable t, IsSymbExpr s, Show a) => s t a -> [t] -> [a]+evaluatorWithParseData = evaluatorWithParseDataAndOptions [] [] ++evaluatorWithParseDataAndOptions :: (Parseable t, IsSymbExpr s, Show a) => ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]+evaluatorWithParseDataAndOptions popts opts p' input = + let SymbExpr (Nt start,vpa2,vpa3) = mkRule ("__Start" <:=> OO [id <$$> p'])+ rules = vpa2 M.empty+ grammar = (start, [ p | (_, alts) <- M.assocs rules, p <- alts ])+ parse_res = GLL.parseWithOptions (popts++[packedNodesOnly,strictBinarisation]) grammar input+ arr = mkInput input + (_,m) = A.bounds arr+ in unsafePerformIO $ do + let (_,prods) = grammar+ nt_set = S.fromList [ x | Prod x _ <- prods ]+ putStrLn $ "#production: " ++ show (length prods)+ putStrLn $ "#nonterminals: " ++ show (length nt_set)+ putStrLn $ "largest nonterminal: " ++ show ( + foldr (\x -> max (Data.Text.length x)) 0 nt_set)++ startTime <- getCurrentTime+ putStrLn $ "#tokens: " ++ (show m)+ putStrLn $ "#successes: " ++ (show $ res_successes parse_res)+ endTime <- getCurrentTime+ putStrLn $ "recognition time: " ++ show (diffUTCTime endTime startTime)+ startTime' <- getCurrentTime+ putStrLn $ "#descriptors " ++ (show $ nr_descriptors parse_res)+ putStrLn $ "#EPNs " ++ (show $ nr_packed_node_attempts parse_res) + endTime <- getCurrentTime+ putStrLn $ "parse-data time: " ++ show (diffUTCTime endTime startTime')+ startTime' <- getCurrentTime+ as <- vpa3 (runOptions opts) emptyAncestors (sppf_result parse_res) arr 0 m+-- putStrLn $ "#derivations: " ++ show (length as)+ when (not (null as)) (writeFile "/tmp/derivation" (show (head as)))+ endTime <- getCurrentTime+ putStrLn $ "semantic phase: " ++ show (diffUTCTime endTime startTime')+ putStrLn $ "total time: " ++ show (diffUTCTime endTime startTime)+ return as+ -- | The grammar of a given parser. grammar :: (Show t, Parseable t, IsSymbExpr s) => s t a -> Grammar t grammar p = (\(f,_,_) -> f) (parse' defaultPOpts defaultOptions p []) +-- | Print some information about the grammar constructed by a 'IsSymbExpr'.+-- useful for debugging purposes+printGrammarData :: (Show t, Parseable t, IsSymbExpr s) => s t a -> IO ()+printGrammarData p = do+ putStrLn $ "production: " ++ show (length prods)+ putStrLn $ "nonterminals: " ++ show (length nt_set)+ putStrLn $ "largest nonterminal: " ++ show ( + foldr (\x -> max (Data.Text.length x)) 0 nt_set)+ where (_,prods) = grammar p+ nt_set = S.fromList [ x | Prod x _ <- prods ]+ -- | -- Runs a parser given a string of 'Parseable's and returns a list of -- semantic results, corresponding to all finitely many derivations.@@ -454,7 +550,7 @@ keyword k = term_parser (upcast (Keyword k)) (const k) -- helper for Char tokens -- | Parse a single integer, using a 'SubsumesToken' type.--- Returns the lexeme interpreted as an integer.+-- Returns the lexeme interpreted as an 'Int'. int_lit :: SubsumesToken t => SymbExpr t Int int_lit = term_parser (upcast (IntLit Nothing)) (unwrap . downcast) where unwrap (Just (IntLit (Just i))) = i@@ -703,7 +799,7 @@ <||> satisfy Nothing where fresh = mkNt p "?" --- | Version of 'optional' that prefers to derive from the given symbol+-- | Version of 'optional' that prefers to derive from the given symbol, -- affects only nullable nonterminal symbols preferably :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) preferably p = fresh @@ -712,7 +808,7 @@ where fresh = mkNt p "?" -- | Version of 'optional' that prefers to derive the empty string from --- the given symbol, effects only nullable nonterminal symbols+-- the given symbol, affects only nullable nonterminal symbols reluctantly :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) reluctantly p = fresh <:= satisfy Nothing @@ -723,7 +819,7 @@ optionalWithDef p def = mkNt p "?" <:=> id <$$> p <||> satisfy def -- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics.-within :: IsSymbExpr s => BNF Token a -> s Token b -> BNF Token c -> BNF Token b+within :: (Show t, Ord t, IsSymbExpr s) => BNF t a -> s t b -> BNF t c -> BNF t b within l p r = mkRule $ l **> toSymb p <** r -- | Place a piece of BNF between the characters '(' and ')'.@@ -738,3 +834,37 @@ quotes p = within (keychar '\'') p (keychar '\'') -- | Place a piece of BNF between two double quotes. dquotes p = within (keychar '"') p (keychar '"')++foldr_multiple :: (IsSymbExpr s, Parseable t) => s t (a -> a) -> a -> BNF t a +foldr_multiple comb def = mkNt comb "-foldr" + <::=> satisfy def + <||> ($) <$$> comb <<<**> foldr_multiple comb def++foldr_multipleSepBy :: (IsSymbExpr s, Parseable t) => s t (a -> a) -> s t b -> a -> BNF t a +foldr_multipleSepBy comb sep def = mkNt comb "-foldr" + <::=> satisfy def + <||> ($ def) <$$> comb+ <||> ($) <$$> comb <** sep <<<**> foldr_multipleSepBy comb sep def++-- | A table mapping operator keywords to a 'Fixity' and 'Assoc'+-- It provides a convenient way to build an expression grammar (see 'fromOpTable'). +type OpTable e = IM.IntMap [(String, Fixity e, Assoc)] +data Assoc = LAssoc | RAssoc | NA+data Fixity e = Prefix (String -> e -> e) | Infix (e -> String -> e -> e)++fromOpTable :: (SubsumesToken t, Parseable t, IsSymbExpr s) => String -> OpTable e -> s t e -> BNF t e +fromOpTable nt ops rec = chooses_prec (nt ++ "-infix-prefix-exprs") $+ [ mkNterm ix row+ | (ix, row) <- zip [1..] (IM.elems ops)+ ]+ where mkNterm ix ops = chooses (ntName ix) $ + [ mkAlt op fix assoc | (op, fix, assoc) <- ops ]+ where mkAlt op fix assoc = case fix of+ Prefix f -> f <$$> keyword op <**> rec + Infix f -> case assoc of + LAssoc -> f <$$> rec <**> keyword op <**>>> rec+ RAssoc -> f <$$> rec <**> keyword op <<<**> rec+ _ -> f <$$> rec <**> keyword op <**> rec+ + ntName i = show i ++ nt ++ "-op-row"+
src/GLL/Combinators/Lexer.hs view
@@ -31,6 +31,8 @@ , altIdentifiers :: RE Char String -- | Arbitrary tokens /(a,b)/. /a/ is the token name, /b/ is a regular expression. , tokens :: [(String, RE Char String)]+ -- | Whether integer literals may be signed positive or negative. Default: 'False'+ , signed_int_lits :: Bool } -- | The default 'LexerSettings'.@@ -38,7 +40,7 @@ emptyLanguage = LexerSettings [] [] isSpace "//" "{-" "-}" ((:) <$> psym isLower <*> lowercase_id) ((:) <$> psym isUpper <*> lowercase_id)- []+ [] False where lowercase_id = many (psym (\c -> isAlpha c || c == '_' || isDigit c)) -- | A lexer using the default 'LexerSettings'.@@ -75,7 +77,7 @@ lTokens lexsets = lCharacters <|> lKeywords- <|> upcast . IntLit . Just <$> lIntegers + <|> upcast . IntLit . Just <$> lIntegers (signed_int_lits lexsets) <|> upcast . FloatLit . Just <$> lFloats <|> upcast . IDLit . Just <$> identifiers lexsets <|> upcast . AltIDLit . Just <$> altIdentifiers lexsets@@ -114,13 +116,16 @@ <*> decimal where mk pre sign dec = pre : maybe "" (:[]) sign ++ dec -lIntegers :: RE Char Int-lIntegers = signed (+lIntegers :: Bool -> RE Char Int+lIntegers True = signed lNaturals+lIntegers False = lNaturals++lNaturals :: RE Char Int +lNaturals = (read <$> decimal) <|> (baseToDec 16 <$ hexPrefix <*> someOf (['0'..'9']++['A'..'F']++['a'..'f'])) <|> (baseToDec 8 <$ octPrefix <*> someOf ['0'..'7']) <|> (baseToDec 2 <$ binPrefix <*> someOf ['0','1'])- ) where hexPrefix = string "0x" <|> string "0X" octPrefix = string "0o" <|> string "0O" binPrefix = string "0b" <|> string "0B"
src/GLL/Combinators/Test/Interface.hs view
@@ -33,7 +33,7 @@ import Data.List (sort, nub) import Data.IORef -import GLL.Combinators.Interface+import GLL.Combinators.BinaryInterface import GLL.Parseable.Char () -- | Defines and executes multiple1 unit-tests @@ -50,7 +50,7 @@ Just ref -> memClear ref j <- readIORef subcount modifyIORef subcount succ- let parse_res = parseWithOptions[useMemoisation] p str+ let parse_res = parseWithParseOptions [noSelectTest] [useMemoisation] p str norm = take 100 . sort . nub norm_p_res = norm parse_res b = norm_p_res == norm res@@ -299,6 +299,27 @@ -- why not ("", [[0]]) ?? [("", [[]]), ("1", [[1],[1]]), ("1;1", [[1,0,1]])]-} + let pX :: BNF Char Int -> BNF Char Int+ pX p = mkNt p "X" <::=> p <||> (+) <$$> pX (p) <**> p+ test Nothing "sequence" (pX ("hash" <:=> 1 <$$ char '1'))+ [("1", [1]), ("11",[2]),("111", [3])+ ,("", []), ("21",[]), ("1(1)1", [])]++ {- tests fails to terminate as the grammar is infinitely big+ let pX :: BNF Char Int -> BNF Char Int+ pX p = mkNt p "X" <::=> p + <||> (+) <$$> pX (within (char '(') p (char ')')) <**> p+ test Nothing "growing sequence (left-recursive)" (pX ("hash" <:=> 1 <$$ char '1'))+ [("1", [1]), ("(1)1",[2]),("((1))(1)1", [3])+ ,("", []), ("11",[]), ("1(1)1", [])]+ -}+ {-let pX :: BNF Char Int -> BNF Char Int+ pX p = mkNt p "X" <::=> p + <||> (+) <$$> p <**> pX (within (char '(') p (char ')'))+ test Nothing "growing sequence (right-recursive)" + (pX ("hash" <:=> 1 <$$ char '1'))+ [("1", [1]),("1(1)",[2]),("1(1)((1))", [3]),("1(1)((1))(((1)))",[4])+ ,("", []), ("11",[]), ("1(1)1", []), ("1(1)(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"]
src/GLL/Combinators/Visit/Join.hs view
@@ -68,8 +68,10 @@ 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) ++ ")"+ where mkName = "_" ++ "(" ++ intercalate "|" (map op (unOO a)) ++ ")"+ where op (AltExpr (rhs,_,_)) = "(" ++ intercalate "*" (map show rhs) ++ ")"+ + -- | -- Class for lifting to 'AltExprs'. class HasAlts a where
src/GLL/Combinators/Visit/Sem.hs view
@@ -50,25 +50,25 @@ 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+ seq k = do as <- q opts ctx' sppf arr k r+ a2bs <- p opts (alt,j-1) ctx'' sppf arr l k return [ (k,a2b a) | (_,a2b) <- a2bs, a <- as ]+ where ctx' | k > l = emptyAncestors + | otherwise = ctx+ ctx'' | k < r = emptyAncestors+ | otherwise = ctx in do ass <- forM choices seq return (concat ass) --- contexts-type Ancestors t = IM.IntMap (IM.IntMap (S.Set Nt))+type Ancestors t = S.Set Nt +emptyAncestors :: Ancestors t+emptyAncestors = S.empty+ inAncestors :: Ancestors t -> (Symbol t, Int, Int) -> Bool inAncestors ctx (Term _, _, _) = False-inAncestors ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx- where inner = maybe False (S.member x) . IM.lookup r+inAncestors ctx (Nt x, l, r) = S.member x ctx toAncestors :: Ancestors t -> (Nt, Int, Int) -> Ancestors t-toAncestors ctx (x, l, r) = IM.alter inner l ctx- where inner mm = case mm of - Nothing -> Just $ singleRX- Just m -> Just $ IM.insertWith (S.union) r singleX m- singleRX = IM.singleton r singleX- singleX = S.singleton x-+toAncestors ctx (x, l, r) = S.insert x ctx
src/GLL/Parser.hs view
@@ -162,11 +162,11 @@ -- ** Smart constructors for creating 'Grammar's start, prod, nterm, term, -- ** Parseable tokens - Parseable(..),+ Parseable(..), Input, mkInput, -- * Run the GLL parser- parse, + parse, parseArray, -- ** Run the GLL parser with options- parseWithOptions,+ parseWithOptions, parseWithOptionsArray, -- *** ParseOptions ParseOptions, ParseOption, strictBinarisation, fullSPPF, allNodes, packedNodesOnly, maximumErrors,@@ -213,6 +213,9 @@ -- | Representation of the input string type Input t = A.Array Int t +mkInput :: (Parseable t) => [t] -> Input t+mkInput input = A.listArray (0,m) (input++[eos])+ where m = length input -- | Types for type LhsParams t = (Nt, Int)@@ -233,15 +236,19 @@ type Pcal t = IM.IntMap (M.Map Nt [Int]) -- | Connecting it all-data Mutable t = Mutable { mut_success :: Bool- , mut_sppf :: SPPF t+data Mutable t = Mutable { mut_sppf :: SPPF t , mut_worklist :: Rcal t , mut_descriptors :: Ucal t , mut_gss :: GSS t , mut_popset :: Pcal t , mut_mismatches :: MisMatches t + , mut_counters :: Counters } +data Counters = Counters { count_successes :: Int+ , count_pnodes :: Int + }+ -- | Monad for implicitly passing around 'context' data GLL t a = GLL (Flags -> Mutable t -> (a, Mutable t)) @@ -296,7 +303,10 @@ where inner = maybe [] id . M.lookup gs in (res, mut) -addSuccess = GLL $ \_ mut -> ((),mut{mut_success = True})+addSuccess = GLL $ \_ mut -> + let mut' = mut { mut_counters = counters { count_successes = 1 + count_successes counters } }+ counters = mut_counters mut+ in ((),mut') getFlags = GLL $ \fs ctx -> (fs, ctx) @@ -332,18 +342,29 @@ parse = parseWithOptions [] -- | +-- Run the GLL parser given a 'Grammar' 't' and an 'Array' of 't's, +-- where 't' is an arbitrary token-type.+-- All token-types must be 'Parseable'.+parseArray :: (Parseable t) => Grammar t -> Input t -> ParseResult t+parseArray = parseWithOptionsArray []++-- | +-- Variant of 'parseWithOptionsArray' where the input is a list of 'Parseable's rather than an 'Array'+parseWithOptions :: Parseable t => ParseOptions -> Grammar t -> [t] -> ParseResult t+parseWithOptions opts gram = parseWithOptionsArray opts gram . mkInput++-- | -- Run the GLL parser given some options, a 'Grammar' 't' and a list of 't's. -- -- If no options are given a minimal 'SPPF' will be created: -- -- * only packed nodes are created -- * the resulting 'SPPF' is not strictly binarised-parseWithOptions :: Parseable t => ParseOptions -> Grammar t -> [t] -> ParseResult t-parseWithOptions opts grammar@(start,_) str = +parseWithOptionsArray :: Parseable t => ParseOptions -> Grammar t -> Input t -> ParseResult t+parseWithOptionsArray opts grammar@(start,_) input = let flags = runOptions opts (mutable,_,_) = gll flags m False grammar input- m = length str - input = A.array (0,m) $ zip [0..] $ str ++ [eos]+ (_, m) = A.bounds input in resultFromMutable input flags mutable (Nt start, 0, m) gll :: Parseable t => Flags -> Int -> Bool -> Grammar t -> Input t -> @@ -351,7 +372,8 @@ gll flags m debug (start, prods) input = (runGLL (pLhs (start, 0)) flags context, selects, follows) where - context = Mutable False emptySPPF [] IM.empty IM.empty IM.empty IM.empty+ context = Mutable emptySPPF [] IM.empty IM.empty IM.empty IM.empty counters+ counters = Counters 0 0 dispatch = do mnext <- getDescr@@ -366,7 +388,7 @@ ] first_ts = S.unions (map snd alts) cands = [ descr | (descr, first_ts) <- alts- , any (matches (input A.! i)) first_ts ]+ , select_test (input A.! i) first_ts ] if null cands then addMisMatch i first_ts else forM_ cands (addDescr Dummy)@@ -383,7 +405,7 @@ where slot = Slot bigx (alpha++[Term tau]) beta pRhs (Slot bigx alpha ((Nt bigy):beta), i, l) sppf = - if any (matches (input A.! i)) first_ts+ if select_test (input A.! i) first_ts then do addGSSEdge ret (slot,l,sppf) rs <- getPops ret -- has ret been popped?@@ -422,27 +444,39 @@ error "select-tests are switched off") where pmap = M.fromListWith (++) [ (x,[pr]) | pr@(Prod x _) <- prods ] follow x = follows M.! x- select rhs x = selects M.! (x,rhs)- select_test t set | do_select_test flags = any (matches t) set- | otherwise = True+ do_test = do_select_test flags + select rhs x | do_test = selects M.! (x,rhs)+ | otherwise = S.empty + where + select_test t set | do_test = any (matches t) set+ | otherwise = True altsOf x = prodMap M.! x merge m1 m2 = IM.unionWith inner m1 m2 where inner = IM.unionWith S.union +count_pnode :: GLL t ()+count_pnode = GLL $ \flags mut -> + let mut' = mut { mut_counters = mut_counters' (mut_counters mut) }+ where mut_counters' counters = counters { count_pnodes = count_pnodes counters + 1 }+ in ((), mut')+ joinSPPFs (Slot bigx alpha beta) sppf l k r = do flags <- getFlags case (flexible_binarisation flags, sppf, beta) of (True,Dummy, _:_) -> return snode (_,Dummy, []) -> do addSPPFEdge xnode pnode addSPPFEdge pnode snode+ count_pnode return xnode (_,_, []) -> do addSPPFEdge xnode pnode addSPPFEdge pnode sppf addSPPFEdge pnode snode+ count_pnode return xnode _ -> do addSPPFEdge inode pnode addSPPFEdge pnode sppf addSPPFEdge pnode snode+ count_pnode return inode where x = last alpha -- symbol before the dot snode = SNode (x, k, r) @@ -464,11 +498,13 @@ -- * The number of GSS edges data ParseResult t = ParseResult{ sppf_result :: SPPF t , res_success :: Bool+ , res_successes :: Int , nr_descriptors :: Int , nr_nterm_nodes :: Int , nr_term_nodes :: Int , nr_intermediate_nodes :: Int , nr_packed_nodes :: Int+ , nr_packed_node_attempts :: Int , nr_sppf_edges :: Int , nr_gss_nodes :: Int , nr_gss_edges :: Int@@ -494,7 +530,8 @@ gss_edges = 1 + sum [ length s | (l,x2s) <- IM.assocs gss , (x,s) <- M.assocs x2s ] 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))+ successes = count_successes (mut_counters mutable)+ in ParseResult sppf (successes > 0) successes usize s_nodes m i_nodes p_nodes (count_pnodes (mut_counters mutable)) sppf_edges gss_nodes gss_edges (renderErrors inp flags (mut_mismatches mutable)) renderErrors :: Parseable t => Input t -> Flags -> MisMatches t -> String renderErrors inp flags mm = render doc @@ -516,6 +553,7 @@ | otherwise = result_string ++ "\n" ++ error_message res where result_string = unlines $ [ "Success " ++ show (res_success res)+ , "#Success " ++ show (res_successes res) , "Descriptors: " ++ show (nr_descriptors res) , "Nonterminal nodes: " ++ show (nr_nterm_nodes res) , "Terminal nodes: " ++ show (nr_term_nodes res)
src/GLL/Types/Grammar.hs view
@@ -174,7 +174,7 @@ showRhs ((Nt x):rhs) = show x ++ showRhs rhs instance (Show t) => Show (Symbol t) where- show (Nt s) = show s+ show (Nt s) = unpack s show (Term t) = show t deriving instance (Ord t) => Ord (Slot t)