diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -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 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.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 diff --git a/src/GLL/Combinators/BinaryInterface.hs b/src/GLL/Combinators/BinaryInterface.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/BinaryInterface.hs @@ -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 '"') 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 @@ -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" + 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 @@ -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" 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 @@ -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"] diff --git a/src/GLL/Combinators/Visit/Join.hs b/src/GLL/Combinators/Visit/Join.hs --- a/src/GLL/Combinators/Visit/Join.hs +++ b/src/GLL/Combinators/Visit/Join.hs @@ -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 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 @@ -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 diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs --- a/src/GLL/Parser.hs +++ b/src/GLL/Parser.hs @@ -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) diff --git a/src/GLL/Types/Grammar.hs b/src/GLL/Types/Grammar.hs --- a/src/GLL/Types/Grammar.hs +++ b/src/GLL/Types/Grammar.hs @@ -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)