fungll-combinators (empty) → 0.1.0.1
raw patch · 11 files changed
+1455/−0 lines, 11 filesdep +TypeComposedep +arraydep +basesetup-changed
Dependencies added: TypeCompose, array, base, containers, gll, pretty, regex-applicative, text, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- changelog.txt +70/−0
- fungll-combinators.cabal +50/−0
- src/GLL/Combinators/Interface.hs +828/−0
- src/GLL/Combinators/Visit/FUNGLL.hs +124/−0
- src/GLL/Combinators/Visit/Join.hs +102/−0
- src/GLL/Combinators/Visit/Sem.hs +77/−0
- src/GLL/ParserCombinators.hs +6/−0
- src/GLL/Types/BSR.hs +67/−0
- src/GLL/Types/DataSets.hs +99/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, L. Thomas van Binsbergen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of L. Thomas van Binsbergen nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.txt view
@@ -0,0 +1,70 @@+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 +0.3.0.9 -> 0.3.0.10+ + exporting chooses+0.3.0.10 -> 0.3.0.11+ + parse option for disabling select test (lookahead)++0.3.0.11 -> 0.4.0.1+ + replaced parser by reduced descriptor GLL (RGLL)+ + renamed GLL.Types.Grammar to GLL.Types.Derivations+ + renamed GLL.Types.Abstract to GLL.Types.Grammar+ + exporting GLL.Types.Grammar, GLL.Types.Derivations, GLL.Combinators.Options, GLL.Combinators.Memoisation, GLL.Flags++0.4.0.1 -> 0.4.0.2+ + generalised `within`+ + different whitespace and comment handling in predefined lexer+ + predefined lexer handles (nested) comment-blocks++0.4.0.2 -> 0.4.0.3+ M added hex, octal and binary representation to integer literals+ + added float literals+ + exporting `preferably` and `reluctantly`+ M renamed `rassoc` to shortest_match+ M renamed `lassoc` to longest_match+ - removed `assoc`+ + version of `chooses` that is left-biased (w.r.t. alternatives)+ + generalised arguments of longest_match and shortest_match to IsAltExpr + + exporting `optionalWithDef`++0.4.0.3 -> 0.4.0.4+ + `chooses` cannot be given an empty list (runtime error)+ + updated `base` dependency++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++0.4.0.11 -> 0.4.0.12+ + export 'grammarOf'+ + let 'parse' throw errors by default+ + changed priorities of operator tables to doubles + + removed need to specify associativity of prefix operators in operator table
+ fungll-combinators.cabal view
@@ -0,0 +1,50 @@+-- Initial haskell-gll.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: fungll-combinators+version: 0.1.0.1+synopsis: GLL parser with simple combinator interface +license: BSD3+license-file: LICENSE+author: L. Thomas van Binsbergen+maintainer: L. Thomas van Binsbergen <ltvanbinsbergen@acm.org>+category: Compilers+build-type: Simple +cabal-version: >=1.22+tested-with: GHC == 8.2.1+copyright: Copyright (C) 2019 L. Thomas van Binsbergen+stability: experimental+description: ++ The package fungll-combinators provides generalised top-down parsing combinators according to the + FUNGLL parsing algorithm [Van Binsbergen et al. 2018]. + .+ Please email any questions, comments and suggestions to the + maintainer.++extra-source-files: changelog.txt++library+ hs-source-dirs : src+ build-depends : base >=4.3.1.0 && <= 5 + , containers >= 0.4+ , array+ , TypeCompose+ , pretty+ , text+ , regex-applicative >= 0.3+ , time >= 1.8+ , gll >= 0.4.0.12+ exposed-modules : GLL.ParserCombinators+ , GLL.Types.BSR+ , GLL.Types.DataSets++ other-modules : GLL.Combinators.Visit.FUNGLL+ , GLL.Combinators.Visit.Sem+ , GLL.Combinators.Visit.Join+ , GLL.Combinators.Interface+ ghc-options: -fwarn-incomplete-patterns -fwarn-monomorphism-restriction -fwarn-unused-imports+ default-language: Haskell2010+ default-extensions: TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances+
+ src/GLL/Combinators/Interface.hs view
@@ -0,0 +1,828 @@+{-# LANGUAGE TypeOperators, FlexibleInstances #-}++{-| ++The user writes a combinator expression representing a grammar.+The represented grammar is extracted and given, together with an input string,+to a back-end parser.+The derivations constructed by the parser act as a guide in the "semantic phase"+in which the combinator expressions are evaluated to produce semantic results+for all derivations. Infinitely many derivations would result in a loop. +This problem is avoided by discarding the derivations that would arise from such a loop.++This library provides +"Control.Applicative"-like parser combinators: '<**>' for sequencing, '<||>' for +choice, '<$$>' for application, 'satisfy' instead of pure and derived +combinators '<**', '**>', '<$$', 'many', 'some' and 'optional'.++The semantic phase might benefit from memoisation (see 'memo'). +Using memoisation voids pureness waranty". ++=== Example usage+This library differs from parser combinator libraries in that combinator expressions+are used to describe a grammar rather than a parser.++A rule is considered to be of the form X ::= a | .. | z, and represented by the combinator+expression.++@+pX = \"X\" '<::=>' altA '<||>' ... '<||>' altZ+@++Alternates (\'a\' ... \'z\') start with the application of +a semantic action using '<$$>' (or variants '<$$' and 'satisfy'). +The alternate is extended with '<**>' (or variants '**>', '<**').++@+altA = action1 '<$$>' 'keychar' \'a\' '<**>' pX+altZ = action2 '<$$>' 'keychar' \'z\'+@++Usability is improved by automatic lifting between expressions that represent symbols+and alternates. The main difference with "Control.Applicative" style parser combinator+libraries is that the user must use '<:=>' (or '<::=>') to represent all recursive +nonterminals and must use '<::=>' to represent all nonterminals that potentially lead+to an infinite number of derivations. It is, however, possible to represent left-recursive+nonterminals.++=== Example++In this example we define expressions for parsing (and evaluating) simple arithmetic +expressions for single digit integers. ++The library is capable of parsing arbitrary token types that are 'Parseable', orderable+and have a 'Show' instance.+This example demonstrates the usage of the builtin 'Token' datatype and uses the+elementary parsers 'keychar' and 'int_lit' to create parsers for character- and integer-terminals.++We define a very simpler lexer first.++@+lexer :: String -> [Token]+lexer [] = []+lexer (x:xs)+ | isDigit x = 'IntLit' (Just (read [x])) : lexer xs+ | otherwise = 'Char' x : lexer xs+@++Note that the Char constructor of the 'Token' type is used for character-level parsing.+Char contains no lexeme, unlike the Int constructor.++Consider the following (highly ambiguous and left-recursive) grammar:++@+Expr ::= Expr \'-\' Expr+ | Expr \'+\' Expr+ | Expr \'*\' Expr+ | Expr \'/\' Expr+ | INT+ | \'(\' Expr \')\'+@++The grammar is translated to the following combinator expression, adding the expected+evaluation functions as semantic actions.++@+pExpr :: BNF Token Int+pExpr = \"Expr\" '<::=>' (-) '<$$>' pExpr '<**' 'keychar' \'-\' '<**>' pExpr+ '<||>' (+) '<$$>' pExpr '<**' 'keychar' \'+\' '<**>' pExpr+ '<||>' (*) '<$$>' pExpr '<**' 'keychar' \'*\' '<**>' pExpr+ '<||>' div '<$$>' pExpr '<**' 'keychar' \'/\' '<**>' pExpr+ '<||>' 'int_lit'+ '<||>' parens pExpr+@++Note that '<**' is used to ignore the parse result of the second argument and that '**>' +is used to ignore the parse result of the first argument. These combinators+help us to define the /derived combinator/s /within/ and /parens/.++@+within :: 'BNF' 'Token' a -> 'BNF' 'Token' b -> 'BNF' 'Token' a -> 'BNF' 'Token' b+within l p r = 'mkRule' $ l '**>' p '<**' r++parens :: 'BNF' 'Token' a -> 'BNF' 'Token' a+parens p = within ('keychar' '(') p ('keychar' ')')+@++All possible evaluations are obtained by invoking the 'parse' function.++@+run1 = 'parse' pExpr (lexer "1+2*2-5") -- [0,1,0,-5,-9] +run2 = 'parse' pExpr (lexer "((1+(2*2))-3)-5") -- [-3]+@++With every introduction of an operator '+', '-', '*' or '/' the number of ambiguities is +multiplied. The number of ambiguities behaves like the sequence https://oeis.org/A000108.++=== Simple disambiguation++This library offers simple disambiguation strategies that are applied post-parse +(the parser still faces the ambiguity, but the semantic evaluation only yields +the results according to the strategy). The disambiguations strategies are still+in the /experimental/ phase. ++We group the operators according to their priorities and use +'<::=' to turn the choice operator '<||>' into a left-biased operator locally+(use 'leftBiased' for the same effect globally).++@+pExpr1 :: BNF Token Int+pExpr1 = \"Expr\" '<::=' ( (-) '<$$>' pExpr1 '<**' 'keychar' \'-\' '<**>' pExpr1+ '<||>' (+) '<$$>' pExpr1 '<**' 'keychar' \'+\' '<**>' pExpr1 )+ '<||>' ( (*) '<$$>' pExpr1 '<**' 'keychar' \'*\' '<**>' pExpr1+ '<||>' div '<$$>' pExpr1 '<**' 'keychar' \'/\' '<**>' pExpr1 )+ '<||>' ( 'int_lit'+ '<||>' 'parens' pExpr1 )++run3 = 'parseWithOptions' ['maximumPivotAtNt'] pExpr1 (lexer "1+2*2-5") -- [0]+@++The option 'maximumPivotAtNt' enables the 'longest-match' disambiguation strategy +and makes the arithmetic operators left-associative.++=== Grammar rewrites++To deal with the particular ambiguities associated with operators we can +rewrite the grammar to disambiguate pre-parse.++We define the /chainl/ combinator for parsing chains of left-associative operators.++@+chainl :: 'BNF' 'Token' a -> 'BNF' 'Token' (a -> a -> a) -> 'BNF' 'Token' a+chainl p s = 'mkRule' $+ foldl (flip ($)) '<$$>' p '<**>' many (flip '<$$>' s '<**>' p)+@++The expression parser is written with chainl as follows:++@+pExpr2 :: BNF Token Int+pExpr2 = pE1+ where pE1 = chainl pE2 (\"E1\" '<::=>' (+) '<$$' 'keychar' \'+\' '<||>' (-) '<$$' 'keychar' \'-\')+ pE2 = chainl pE3 (\"E2\" '<::=>' (*) '<$$' 'keychar' \'*\' '<||>' div '<$$' 'keychar' \'/\')+ pE3 = \"E3\" '<::=>' 'int_lit' '<||>' parens pExpr2++run4 = 'parse' 'pExpr2' (lexer "1+2*2-5") -- [0]+@++Pre-parse disambiguation is desirable, as the parsing process could +speed up dramatically. In general however, it is not always possible to find +the appropriate grammar rewrite and implement it in a high-level combinator such +as chainl, /motivating the existence of this library/.++More simple examples can be found in "GLL.Combinators.Test.Interface".++-}+module GLL.Combinators.Interface (+ -- * 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, AltExpr, AltExprs,+ -- ** Parseable token types + Token(..), Parseable(..), SubsumesToken(..), unlexTokens, unlexToken, + -- * Running a parser + parse, printParseData, evaluatorWithParseData,+ -- ** Running a parser with options+ parseWithOptions, parseWithParseOptions, evaluatorWithParseDataAndOptions, + printParseDataWithOptions, + --printGrammarData,+ -- *** Possible options+ CombinatorOptions, CombinatorOption, + GLL.Combinators.Options.maximumErrors, throwErrors, + maximumPivot, maximumPivotAtNt,leftBiased,+ -- *** 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,+ foldr_multiple, foldr_multipleSepBy,+ -- *** Operator expressions+ fromOpTable, opTableFromList, OpTable, Assoc(..), Fixity(..),+ -- *** Disambiguation + (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>),+ longest_match,shortest_match,+ many, many1, some, some1, + manySepBy, manySepBy1, manySepBy2, + someSepBy, someSepBy1,someSepBy2,+ -- * Lifting+ HasAlts(..), IsSymbExpr(..), IsAltExpr(..),+ -- * Memoisation+ memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation,+ ) where++import GLL.Combinators.Options+import GLL.Combinators.Visit.FUNGLL+import GLL.Combinators.Visit.Join+import GLL.Combinators.Visit.Sem+import GLL.Combinators.Memoisation+import GLL.Combinators.Lexer+import GLL.Types.Grammar+import GLL.Types.DataSets+import GLL.Types.BSR+import GLL.Flags hiding (runOptions)+import GLL.Parseable.Char++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] -> (ParseResult t, Either String [a])+parse' popts opts p' input = + let SymbExpr (Nt lower_start, vpa2, vpa3) = + mkRule ("__Augment" <:=> OO [id <$$> p'])+ start = pack "__Start"+ arr = mkInput input + m = length input + parse_res = parser_for start vpa2 arr+ as = evaluator_for lower_start vpa3 opts (bsrs_result parse_res) arr+ res_list = unsafePerformIO as+ in (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 lower_start,vpa2,vpa3) = toSymb p'+ start = pack "__Start"+ parse_res = parser_for start vpa2 arr+ arr = mkInput input + (_,m) = A.bounds arr+ in do 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 $ "#BSRs " ++ (show $ nr_bsrs parse_res) + endTime <- getCurrentTime+ putStrLn $ "parse-data time: " ++ 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 lower_start,vpa2,vpa3) = toSymb p'+ start = pack "__Start"+ parse_res = parser_for start vpa2 arr+ arr = mkInput input + (_,m) = A.bounds arr+ in unsafePerformIO $ do + 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 $ "#BSRs " ++ (show $ nr_bsrs parse_res) + endTime <- getCurrentTime+ putStrLn $ "parse-data time: " ++ show (diffUTCTime endTime startTime')+ startTime' <- getCurrentTime+ as <- evaluator_for start vpa3 (runOptions opts) (bsrs_result parse_res) arr+-- 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+-- | +-- Runs a parser given a string of 'Parseable's and returns a list of +-- semantic results, corresponding to all finitely many derivations.+parse :: (Show t, Parseable t, IsSymbExpr s) => s t a -> [t] -> [a]+parse = parseWithOptions [throwErrors] ++-- | +-- Run the parser with some 'CombinatorOptions'.+parseWithOptions :: (Show t, Parseable t, IsSymbExpr s) => + CombinatorOptions -> s t a -> [t] -> [a]+parseWithOptions opts p ts = parseWithParseOptions defaultPOpts opts p ts++-- | +-- Run the parser with some 'ParseOptions' and 'CombinatorOptions'.+parseWithParseOptions :: (Show t, Parseable t, IsSymbExpr s) => + ParseOptions -> CombinatorOptions -> s t a -> [t] -> [a]+parseWithParseOptions pcopts opts p ts = + case parseWithParseOptionsAndError pcopts opts p ts of+ Left str | throw_errors opts' -> error str+ | otherwise -> []+ Right as -> as+ where opts' = runOptions opts++-- | +-- Run the parser with some 'CombinatorOptions' and return either an error or the results.+-- Any returned results will be a list of length greater than 0.+parseWithOptionsAndError :: (Show t, Parseable t, IsSymbExpr s) => + CombinatorOptions -> s t a -> [t] -> Either String [a]+parseWithOptionsAndError opts p = parseWithParseOptionsAndError defaultPOpts opts p ++-- | +-- Run the parser with some 'ParseOptions' and 'CombinatorOptions'.+-- Returns either an error or the results.+-- Any returned results will be a list of length greater than 0.+parseWithParseOptionsAndError :: (Show t, Parseable t, IsSymbExpr s) => + ParseOptions -> CombinatorOptions -> s t a -> [t] -> Either String [a]+parseWithParseOptionsAndError popts opts p = (\(_,t) -> t) . parse' defaultPOpts (runOptions opts) p+++-- | Get the 'ParseResult', containing an 'SPPF', +-- produced by parsing the given input with the given parser.+parseResult :: (Show t, Parseable t, IsSymbExpr s) => s t a -> [t] -> ParseResult t+parseResult = parseResultWithOptions [] [] ++-- | Get the 'ParseResult' given some 'ParseOptions' and 'CombinatorOptions'. +parseResultWithOptions :: (Show t, Parseable t, IsSymbExpr s) => + ParseOptions -> CombinatorOptions -> s t a -> [t] -> ParseResult t+parseResultWithOptions popts opts p str = + (\(s,_) -> s) $ parse' popts (runOptions opts) p str++defaultPOpts = [strictBinarisation, packedNodesOnly]++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, HasAlts b) => String -> b t a -> SymbExpr t a +x <:=> altPs = mkNtRule False False x altPs+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, HasAlts b) => String -> b t a -> SymbExpr t a +x <::=> altPs = mkNtRule True False x altPs++-- | Variant of '<::=>' that can be supplied with a list of alternates+chooses :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a+chooses p alts | null alts = error "chooses cannot be given an empty list of alternatives"+ | otherwise = (<::=>) p (OO (map toAlt alts))++-- | Variant of '<::=' that can be supplied with a list of alternates+chooses_prec :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a+chooses_prec p alts | null alts = error "chooses cannot be given an empty list of alternatives"+ | otherwise = (<::=) p (OO (map toAlt alts))++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' = join_apply f 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, IsAltExpr i, IsSymbExpr s) => + i t (a -> b) -> s t a -> AltExpr t b+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'+-- The resuling '[] :. AltExpr' forms the right-hand side of a rule.+(<||>) :: (Show t, Ord t, IsAltExpr i, HasAlts b) => i t a -> b t a -> AltExprs t a+l' <||> r' = let l = toAlt l'+ r = altsOf r'+ in OO (l : r)++-- |+-- Apply this combinator to an alternative to turn all underlying occurrences+-- of '<**>' (or variants) apply 'longest match'.+longest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a+longest_match isalt = AltExpr (v1,v2,\opts -> v3 (maximumPivot opts))+ where AltExpr (v1,v2,v3) = toAlt isalt ++-- Apply this combinator to an alternative to turn all underlying occurrences+-- of '<**>' (or variants) apply 'shortest match'.+shortest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a+shortest_match isalt = AltExpr (v1,v2,\opts -> v3 (minimumPivot opts))+ where AltExpr (v1,v2,v3) = toAlt isalt ++-- | Create a symbol-parse for a terminal given:+--+-- * The 'Parseable' token represented by the terminal.+-- * A function from that 'Parseable' to a semantic result.+term_parser :: Parseable t => t -> (t -> a) -> SymbExpr t a +term_parser t f = SymbExpr (Term t, parse_term t,\_ _ _ arr l _ -> return [f (arr A.! l)])++-- | Parse a single character.+--+-- @+-- char c = term_parser c id+-- @+--+-- Currently, this is the only character-level combinator exported+-- by this module. Please use token-level combinators for practical parsing.+-- Might change in the future.+char :: Char -> SymbExpr Char Char+char c = term_parser c id+{-+-- | Parse a list of characters.+string :: [Char] -> SymbExpr Char [Char]+string [] = mkRule $ satisfy []+string (c:cs) = mkRule $ (:) <$$> char c <**> string cs++-- | +-- Apply a parser within two other parsers.+within :: IsSymbExpr s => BNF Char a -> s Char b -> BNF Char c -> BNF Char b+within l p r = mkRule $ l *> (toSymb p) <* r++-- | +-- Apply a parser within parentheses.+-- parens p = within (char '(') p (char ')')+parens :: BNF Char a -> BNF Char a +parens p = within (char '(') p (char ')')+-}++-- | Parse a single character, using a 'SubsumesToken' type.+keychar :: (Parseable t, SubsumesToken t) => Char -> SymbExpr t Char+keychar c = term_parser (upcast (Char c)) (const c) -- helper for Char tokens++-- | Parse a single character, using a 'SubsumesToken' type.+keyword :: (Parseable t, SubsumesToken t) => String -> SymbExpr t String+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 'Int'.+int_lit :: (Parseable t, SubsumesToken t) => SymbExpr t Int+int_lit = term_parser (upcast (IntLit Nothing)) (unwrap . downcast)+ where unwrap (Just (IntLit (Just i))) = i+ unwrap _ = error "int_lit: downcast, or token without lexeme"++-- | Parse a single floating point literal, using a 'SubsumesToken' type.+-- Returns the lexeme interpreted as a 'Double'.+float_lit :: (Parseable t, SubsumesToken t) => SymbExpr t Double+float_lit = term_parser (upcast (FloatLit Nothing)) (unwrap . downcast)+ where unwrap (Just (FloatLit (Just i))) = i+ unwrap _ = error "float_lit: downcast, or token without lexeme"++-- | Parse a single Boolean, using a 'SubsumesToken' type.+-- Returns the lexeme interpreter as a Boolean.+bool_lit :: (Parseable t, SubsumesToken t) => SymbExpr t Bool+bool_lit = term_parser (upcast (BoolLit Nothing)) (unwrap . downcast)+ 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 :: (Parseable t, 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 :: (Parseable t, SubsumesToken t) => SymbExpr t String+string_lit = term_parser (upcast (StringLit Nothing)) (unwrap . downcast)+ where unwrap (Just (StringLit (Just i))) = i+ unwrap _ = error "string_lit: downcast, or token without lexeme"++-- | Parse a single identifier, using a 'SubsumesToken' type.+-- Returns the lexeme as a String.+id_lit :: (Parseable t, SubsumesToken t) => SymbExpr t String+id_lit = term_parser (upcast (IDLit Nothing)) (unwrap . downcast)+ where unwrap (Just (IDLit (Just i))) = i+ unwrap _ = error "id_lit: downcast, or token without lexeme"++-- | Parse a single alternative identifier, using a 'SubsumesToken' type.+-- Returns the lexeme as a String.+alt_id_lit :: (Parseable t, SubsumesToken t) => SymbExpr t String+alt_id_lit = term_parser (upcast (AltIDLit Nothing)) (unwrap . downcast)+ where unwrap (Just (AltIDLit (Just i))) = i+ unwrap _ = error "alt_id_lit: downcast, or token without lexeme"+++-- | Parse a single arbitrary token, using a 'SubsumesToken' type.+-- Returns the lexeme.+token :: (Parseable t, SubsumesToken t) => String -> SymbExpr t String+token name = term_parser (upcast (Token name Nothing)) (unwrap . downcast)+ where unwrap (Just (Token name' (Just i))) | name == name' = i+ unwrap _ = error "tokenT: downcast, or token without lexeme"++epsilon :: (Show t, Ord t) => AltExpr t ()+epsilon = AltExpr ([], seqStart ,\_ _ _ _ _ l r -> + if l == r then return [(l,())] else return [] )+ where x = "__eps"++-- | The empty right-hand side that yields its +-- first argument as a semantic result.+satisfy :: (Show t, Ord t ) => a -> AltExpr t a+satisfy a = a <$$ epsilon++-- | +-- 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, IsSymbExpr s) => MemoRef [a] -> s t a -> SymbExpr t a+memo ref p' = let SymbExpr (sym,rules,sem) = toSymb p'+ lhs_sem opts ctx sppf arr l r + | not (do_memo opts) = sem opts ctx sppf arr l r+ | otherwise = do+ tab <- readIORef ref+ case memLookup (l,r) tab of+ Just as -> return as+ Nothing -> do as <- sem opts ctx sppf arr l r+ modifyIORef ref (memInsert (l,r) as)+ return as+ in SymbExpr (sym, rules, lhs_sem)++-- | +-- 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, IsSymbExpr s) => s t a -> String -> String +mkNt p str = let SymbExpr (myx,_,_) = mkRule p+ in "_(" ++ show myx ++ ")" ++ str++-- | Specialised fmap for altparsers+(.$.) :: (Show t, Ord t, IsAltExpr i) => (a -> b) -> i t a -> AltExpr t b+f .$. i = let AltExpr (s,r,sem) = toAlt i+ in AltExpr (s,r,\opts slot ctx sppf arr l r -> + do as <- sem opts slot ctx sppf arr l r+ return $ map (id *** f) as )++-- | +-- 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 <$$++-- | +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++-- 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 <**, <<<**, <**>>+-- | +-- 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 ++-- | 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 ++-- | +-- Variant of '<::=>' that prioritises productions from left-to-right (or top-to-bottom).+x <::= altPs = mkNtRule True True x altPs +infixl 2 <::=++-- | +-- 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_ (<<<**>)++-- | 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_ (<<<**>) ++-- | 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_ (<**>>>)++-- | 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_ (<**>>>) ++-- | 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_ (<**>)++-- | 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_ (<**>)++-- | 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, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+manySepBy = sepBy many+-- | Same as 'many1' but with an additional separator.+manySepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+manySepBy1 = sepBy1 many+-- | Same as 'some1' but with an additional separator.+someSepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+someSepBy = sepBy some+-- | Same as 'some1' but with an additional separator.+someSepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+someSepBy1 = sepBy1 some+-- | Same as 'multiple' but with an additional separator.+multipleSepBy :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+multipleSepBy = sepBy multiple +-- | Same as 'multiple1' but with an additional separator.+multipleSepBy1 :: (Show t, Ord t, IsSymbExpr s, IsSymbExpr s2, IsAltExpr s2) => + s t a -> s2 t b -> SymbExpr t [a]+multipleSepBy1 = sepBy1 multiple ++sepBy :: (Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) => + (AltExpr t a -> SymbExpr t [a]) -> s1 t a -> s2 t b -> SymbExpr t [a]+sepBy mult p c = mkRule $ satisfy [] <||> (:) <$$> p <**> mult (c **> p)++sepBy1 :: (Show t, Ord t, IsSymbExpr s1, IsSymbExpr s2, IsAltExpr s2) => + (AltExpr t a -> SymbExpr t [a]) -> s1 t a -> s2 t b -> SymbExpr 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, IsSymbExpr s) => s t a -> SymbExpr 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, IsSymbExpr s) => s t a -> SymbExpr 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, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)+reluctantly p = fresh + <:= satisfy Nothing + <||> Just <$$> p+ where fresh = mkNt p "?"++optionalWithDef :: (Show t, Ord t, IsSymbExpr s) => s t a -> a -> SymbExpr 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, 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 ')'.+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 '"')++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 = M.Map Double [(String, Fixity e)] +data Fixity e = Prefix (String -> e -> e) | Infix (e -> String -> e -> e) Assoc+data Assoc = LAssoc | RAssoc | NA++opTableFromList :: [(Double, [(String, Fixity e)])] -> OpTable e +opTableFromList = M.fromList++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..] (M.elems ops)+ ]+ where mkNterm ix ops = chooses (ntName ix) $ + [ mkAlt op fix | (op, fix) <- ops ]+ where mkAlt op fix = case fix of+ Prefix f -> f <$$> keyword op <**> rec + Infix f assoc -> 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/Visit/FUNGLL.hs view
@@ -0,0 +1,124 @@++module GLL.Combinators.Visit.FUNGLL where++import GLL.Types.Grammar+import GLL.Types.BSR+import GLL.Types.DataSets++import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntSet as IS+import qualified Data.Array as A++type Command t = State t (ContF t) -> State t (ContF t)+data ContF t = ContF (Descr t -> Command t)++type Parse_Symb t = (Symbol t, Input t -> Slot t -> Int -> Int -> ContF t -> Command t)+type Parse_Choice t = Input t -> Nt -> Int -> ContF t -> Command t +type Parse_Seq t = Input t -> Nt -> [Symbol t] -> Int -> ContF t -> Command t+type Parse_Alt t = Parse_Seq t++parser_for :: (Parseable t) => Nt -> Parse_Symb t -> Input t -> ParseResult t+parser_for x (Term t,p) inp = error "assert: terminal given to parser_for"+parser_for x (Nt s,p) inp = resultFromState inp (+ p inp (Slot x [Nt s] []) 0 0 cont0 emptyState) (s,0,0)+ where cont0 = ContF cf+ where cf (_,_,r) s | r == snd (A.bounds inp) = s { successes = successes s + 1 } + | otherwise = s++parse_nterm :: (Ord t) => Nt -> [Parse_Seq t] -> Parse_Symb t+parse_nterm n = nterm n . foldl altOp altStart ++parse_term :: Parseable t => t -> Parse_Symb t+parse_term = term++parse_apply :: Ord t => Parse_Symb t -> Parse_Seq t+parse_apply = seqOp seqStart ++parse_seq :: Ord t => Parse_Seq t -> Parse_Symb t -> Parse_Seq t+parse_seq = seqOp++nterm :: (Ord t) => Nt -> Parse_Choice t -> Parse_Symb t+nterm n p = (Nt n, parser)+ where parser inp g l k c s + | null rs = p inp n k cont_for s'+ | otherwise = compAll [ applyCF c (g,l,r) | r <- rs ] s'+ where s' = s { grel = addCont (n,k) (g,l,c) (grel s) } + rs = extents (n,k) (prel s) ++ cont_for = ContF cf + where cf (_,k,r) s = + compAll [ applyCF c (g,l',r) | (g,l',c) <- conts (n,k) (grel s) ] s'+ where s' = s { prel = addExtent (n,k) r (prel s) }++term :: Parseable t => t -> Parse_Symb t+term t = (Term t, parser)+ where parser inp g l k c s+ | lb <= k, k <= ub, matches (inp A.! k) t = applyCF c (g, l, k+1) s+ | otherwise = s+ where (lb,ub) = A.bounds inp++seqStart :: Ord t => Parse_Seq t+seqStart inp x beta l c = continue (Slot x [] beta, l, l, l) c++seqOp :: Ord t => Parse_Seq t -> Parse_Symb t -> Parse_Seq t+seqOp p (s,q) inp x beta l c0 = p inp x (s:beta) l c1+ where c1 = ContF c1f+ where c1f ((Slot _ alpha _),l,k) = q inp (Slot x (alpha++[s]) beta) l k c2+ where c2 = ContF c2f+ where c2f (g,l,r) = continue (g,l,k,r) c0++continue :: (Ord t) => BSR t -> ContF t -> Command t+continue bsr@(g@(Slot x alpha beta),l,k,r) c s + | hasDescr descr (uset s) = s'+ | otherwise = applyCF c descr s''+ where descr = (g,l,r)+ s' | not (null alpha) || null beta = s { bsrs = addBSR bsr (bsrs s) }+ | otherwise = s+ s'' = s' { uset = addDescr descr (uset s') }++altStart :: Parse_Choice t+altStart inp n l c s = s++altOp :: Parse_Choice t -> Parse_Seq t -> Parse_Choice t+altOp p q inp n l c = p inp n l c . q inp n [] l c++compAll :: [Command t] -> Command t+compAll = foldr (.) id++applyCF (ContF cf) a = cf a++-- | +-- The "ParseResult" datatype contains some information about a parse:+--+-- * Whether the parse was successful+-- * The number of descriptors that have been processed+-- * The number of BSR elements +data ParseResult t = ParseResult{ bsrs_result :: BSRs t+ , res_success :: Bool+ , res_successes :: Int+ , nr_descriptors :: Int+ , nr_bsrs :: Int+ , error_message :: String+ }++resultFromState :: Parseable t => Input t -> State t c -> (Nt, Int, Int) -> ParseResult t+resultFromState inp (State uset _ _ pMap cs) (s, l, m) =+ let usize = sum [ S.size s | (l, r2s) <- IM.assocs uset+ , (r,s) <- IM.assocs r2s ]+ p_nodes = sum [ IS.size ks | (l, r2j) <- IM.assocs pMap+ , (r, j2s) <- IM.assocs r2j+ , (j, s2k) <- IM.assocs j2s+ , (s, ks) <- M.assocs s2k ]+ in ParseResult pMap (cs > 0) cs usize p_nodes "no errors to report" ++instance Show (ParseResult t) where+ show res | res_success res = result_string+ | 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)+ , "BSRs: " ++ show (nr_bsrs res)+ ]
+ src/GLL/Combinators/Visit/Join.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances #-}++module GLL.Combinators.Visit.Join where++import GLL.Types.BSR+import GLL.Types.Grammar+import GLL.Combinators.Visit.Sem+import GLL.Combinators.Visit.FUNGLL+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, Parse_Symb 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], Parse_Alt 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, parse_nterm x 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],parse_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], parse_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 = "_" ++ "(" ++ 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+
+ src/GLL/Combinators/Visit/Sem.hs view
@@ -0,0 +1,77 @@++module GLL.Combinators.Visit.Sem where++import GLL.Combinators.Options+import GLL.Types.Grammar+import GLL.Types.BSR++import Control.Monad (forM)+import qualified Data.Array as A+import qualified Data.IntMap as IM+import qualified Data.Set as S++type Sem_Symb t a = PCOptions -> Ancestors t + -> BSRs t -> Input t -> Int -> Int -> IO [a]+type Sem_Alt t a = PCOptions -> (Prod t,Int) -> Ancestors t + -> BSRs t -> Input t -> Int -> Int -> IO [(Int,a)]++evaluator_for :: (Ord t) => Nt -> Sem_Symb t a -> PCOptions -> BSRs t -> Input t -> IO [a]+evaluator_for start sem opts bsrs inp = sem opts emptyAncestors bsrs inp 0 (snd (A.bounds inp))++sem_nterm :: Bool -> Bool -> Nt -> [Prod t] -> [Sem_Alt t a] -> Sem_Symb t a+sem_nterm use_ctx left_biased x alts ps opts ctx sppf arr l r =+ let ctx' = ctx `toAncestors` (x,l,r)+ sems = zip alts ps + seq (alt@(Prod _ rhs), va3) = + va3 opts (alt,length rhs) ctx' sppf arr l r + in if use_ctx && ctx `inAncestors` (Nt x, l, r) + then return []+ else do ass <- forM sems seq+ let choices = case (pivot_select_nt opts, pivot_select opts) of+ (True,Just compare) -> maintainWith compare ass+ _ -> ass+ return (concatChoice left_biased opts (map (map snd) choices))+ where+ concatChoice :: Bool -> PCOptions -> [[a]] -> [a]+ concatChoice left_biased opts ress = + if left_biased || left_biased_choice opts+ then firstRes ress+ else concat ress+ where firstRes [] = []+ firstRes ([]:ress) = firstRes ress+ firstRes (res:_) = res++sem_apply :: Ord t => (a -> b) -> Sem_Symb t a -> Sem_Alt t b+sem_apply f p opts (alt,j) ctx sppf arr l r = + let op f a = (r,f a)+ 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 => 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 (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+ 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 = 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) = S.member x ctx ++toAncestors :: Ancestors t -> (Nt, Int, Int) -> Ancestors t+toAncestors ctx (x, l, r) = S.insert x ctx
+ src/GLL/ParserCombinators.hs view
@@ -0,0 +1,6 @@++module GLL.ParserCombinators (+ module GLL.Combinators.Interface + ) where++import GLL.Combinators.Interface
+ src/GLL/Types/BSR.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE StandaloneDeriving #-}++module GLL.Types.BSR where++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Set as S +import qualified Data.IntSet as IS +import Data.List (elemIndices, findIndices)++import GLL.Types.Grammar++type Input t = A.Array Int t+-- make sure that tokens are equal independent of their character level value+type SlotL t = (Slot t, Int) -- slot with left extent+type PrL t = (Prod t, Int) -- Production rule with left extent+type NtL = (Nt, Int) -- Nonterminal with left extent++-- | +-- Stores packed nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * dot position (from left to right)+-- * mapping from productions to set of pivots+type BSRs t = IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))+type BSR t = (Slot t, Int, Int, Int)++emptyBSRs :: (Ord t) => BSRs t+emptyBSRs = IM.empty++pNodeLookup :: (Ord t) => BSRs t -> (Slot t, Int, Int) -> Maybe [Int]+pNodeLookup bsrs (Slot x alpha beta,l,r)= pNodeLookup' bsrs ((Prod x (alpha++beta),length alpha),l,r)++pNodeLookup' :: (Ord t) => BSRs t -> ((Prod t, Int), Int, Int) -> Maybe [Int]+pNodeLookup' pMap ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap+ where inner = maybe Nothing inner2 . IM.lookup r+ inner2 = maybe Nothing inner3 . IM.lookup j+ inner3 = maybe Nothing (Just . IS.toList) . M.lookup alt++addBSR = pMapInsert+addBSR, pMapInsert :: (Ord t) => BSR t -> BSRs t -> BSRs t+pMapInsert f@((Slot x alpha beta), l, k, r) pMap = + add (Prod x (alpha++beta)) (length alpha) l r k+ where add alt j l r k = IM.alter addInnerL l pMap+ where addInnerL mm = case mm of + Nothing -> Just singleRJAK+ Just m -> Just $ IM.alter addInnerR r m+ addInnerR mm = case mm of+ Nothing -> Just singleJAK+ Just m -> Just $ IM.alter addInnerJ j m+ addInnerJ mm = case mm of+ Nothing -> Just singleAK+ Just m -> Just $ M.insertWith IS.union alt singleK m+ singleRJAK= IM.fromList [(r, singleJAK)]+ singleJAK = IM.fromList [(j, singleAK)]+ singleAK = M.fromList [(alt, singleK)]+ singleK = IS.singleton k++showBSRs pMap = unlines [ show ((a,j),l,r) ++ " --> " ++ show kset+ | (l,r2j) <- IM.assocs pMap, (r,j2a) <- IM.assocs r2j+ , (j,a2k) <- IM.assocs j2a, (a,kset) <- M.assocs a2k ]++mkInput :: (Parseable t) => [t] -> Input t+mkInput input = A.listArray (0,m) (input++[eos])+ where m = length input
+ src/GLL/Types/DataSets.hs view
@@ -0,0 +1,99 @@++module GLL.Types.DataSets where++import GLL.Types.Grammar+import GLL.Types.BSR++import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Set as S+import Data.List (nub)++type Descr t = (Slot t, Int, Int)+type Comm t = (Nt, Int)+data Cont t c = Cont (Slot t, Int) c+data State t c = State { uset :: USet t+ , grel :: GRel t c+ , prel :: PRel t+ , bsrs :: BSRs t+ , successes :: Int+ }++instance (Ord t) => Ord (Cont t c) where+ (Cont c _) `compare` (Cont c' _) = c `compare` c'++instance (Eq t) => Eq (Cont t c) where+ (Cont c _) == (Cont c' _) = c == c'++emptyUSet :: USet t+addDescr :: (Ord t) => Descr t -> USet t -> USet t+hasDescr :: (Ord t) => Descr t -> USet t -> Bool++emptyG :: GRel t c+addCont :: (Ord t) => Comm t -> (Slot t, Int, c) -> GRel t c -> GRel t c+conts :: Comm t -> GRel t c -> [(Slot t, Int, c)]++emptyP :: PRel t+addExtent :: Comm t -> Int -> PRel t -> PRel t+extents :: Comm t -> PRel t -> [Int]++emptyState :: (Ord t) => State t c+emptyState = State emptyUSet emptyG emptyP emptyBSRs 0++type RList t = [Descr t]+type USet t = IM.IntMap (IM.IntMap (S.Set (Slot t)))+type GRel t c = IM.IntMap (M.Map Nt (S.Set (Cont t c)))+type PRel t = IM.IntMap (M.Map Nt [Int])++descrs2list :: USet t -> [(Slot t, Int, Int)]+descrs2list uset = [ (g,l,k)+ | (l, k2m) <- IM.assocs uset+ , (k, g2m) <- IM.assocs k2m+ , g <- S.toList g2m ]++printDescrs :: (Show t) => USet t -> IO ()+printDescrs = putStr . unlines . map show . descrs2list++emptyRList = []+popRList (x:xs) = (x,xs) +popRList _ = error "popRList"+unionRList = flip (++)+singletonRList = (:[])+fromListRList :: Ord t => [Descr t] -> USet t -> RList t+fromListRList ds uset = foldr op emptyRList (nub ds)+ where op d rset | hasDescr d uset = rset+ | otherwise = unionRList (singletonRList d) rset+++emptyUSet = IM.empty++addDescr alt@(slot,i,l) = IM.alter inner i + where inner mm = case mm of + Nothing -> Just $ IM.singleton l single + Just m -> Just $ IM.insertWith (S.union) l single m+ single = S.singleton slot++hasDescr alt@(slot,i,l) = not . maybe True inner . IM.lookup i+ where inner m = maybe True (not . (slot `S.member`)) $ IM.lookup l m++emptyG = IM.empty+singleCG k v = addCont k v emptyG+addCont (n,i) (gs,l,c) = IM.alter inner i+ where inner mm = case mm of + Nothing -> Just $ M.singleton n single + Just m -> Just $ M.insertWith S.union n single m+ single = S.singleton (Cont (gs,l) c)+conts (n,l) = maybe [] inner . IM.lookup l+ where inner m = maybe [] (map unCont . S.toList) $ M.lookup n m+ unCont (Cont (gs,l') cf) = (gs,l',cf)++emptyP = IM.empty+addExtent (gs,l) i = IM.alter inner l+ where inner mm = case mm of + Nothing -> Just $ M.singleton gs [i]+ Just m -> Just $ M.insertWith (++) gs [i] m++extents (gs,l) = maybe [] inner . IM.lookup l + where inner = maybe [] id . M.lookup gs++