gll 0.3.0.10 → 0.4.0.2
raw patch · 14 files changed
+694/−595 lines, 14 filesdep ~base
Dependency ranges changed: base
Files
- changelog.txt +13/−0
- gll.cabal +13/−11
- src/GLL/Combinators/Interface.hs +44/−27
- src/GLL/Combinators/Lexer.hs +29/−10
- src/GLL/Combinators/Options.hs +46/−1
- src/GLL/Combinators/Visit/Grammar.hs +1/−1
- src/GLL/Combinators/Visit/Join.hs +1/−1
- src/GLL/Combinators/Visit/Sem.hs +1/−1
- src/GLL/Flags.hs +65/−0
- src/GLL/Parseable/Char.hs +1/−1
- src/GLL/Parser.hs +51/−106
- src/GLL/Types/Abstract.hs +0/−159
- src/GLL/Types/Derivations.hs +290/−0
- src/GLL/Types/Grammar.hs +139/−277
changelog.txt view
@@ -11,3 +11,16 @@ 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
gll.cabal view
@@ -3,7 +3,7 @@ -- The name of the package. name: gll-version: 0.3.0.10+version: 0.4.0.2 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE@@ -17,8 +17,8 @@ stability: experimental description: - The package gll provides generalised top-down parsing according to the GLL- parsing algorithm [Scott and Johnstone 2010,2013]. + The package gll provides generalised top-down parsing according to the + (R)GLL parsing algorithm [Scott and Johnstone 2016]. . The user can either invoke the GLL parser directly by importing "GLL.Parser" and providing a@@ -40,7 +40,7 @@ library hs-source-dirs : src- build-depends : base >=4.3.1.0 && <= 4.8.2.0+ build-depends : base >=4.3.1.0 && <= 4.9.0.0 , containers >= 0.4 , array , TypeCompose@@ -48,16 +48,18 @@ , text , regex-applicative >= 0.3 exposed-modules : GLL.Combinators.Interface- , GLL.Combinators.Test.Interface , GLL.Combinators- , GLL.Parser- , GLL.Parseable.Char- other-modules : GLL.Types.Abstract- , GLL.Combinators.Memoisation+ , GLL.Combinators.Test.Interface , GLL.Combinators.Options+ , GLL.Combinators.Memoisation , GLL.Combinators.Lexer- , GLL.Types.Grammar- , GLL.Combinators.Visit.Grammar+ , GLL.Parser+ , GLL.Parseable.Char+ , GLL.Types.Derivations+ , GLL.Types.Grammar + , GLL.Flags++ other-modules : GLL.Combinators.Visit.Grammar , GLL.Combinators.Visit.Sem , GLL.Combinators.Visit.Join extensions : TypeOperators, FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances
src/GLL/Combinators/Interface.hs view
@@ -3,7 +3,7 @@ {-| This module provides a combinator library in which combinators act as an interface to a back-end parser. This technique is inspired by Tom Ridge (2014) and - Peter Ljunglöf (2002).+ Peter Ljunglöf (2002). The back-end parser is provided in "GLL.Parser". The library is fully general: it enables writing parsers for arbitrary context-free grammars. @@ -20,8 +20,8 @@ choice, '<$$>' for application, 'satisfy' instead of pure and derived combinators '<**', '**>', '<$$', 'many', 'some' and 'optional'. -The semantic phase might benefit from memoisation which is provided in a separate (impure)-library "GLL.Combinators.MemInterface". +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@@ -31,10 +31,10 @@ expression. @-pX = "X" '<::=>' altA '<||>' ... '<||>' altZ+pX = \"X\" '<::=>' altA '<||>' ... '<||>' altZ @ -Alternates ('a' ... 'z') start with the application of +Alternates (\'a\' ... \'z\') start with the application of a semantic action using '<$$>' (or variants '<$$' and 'satisfy'). The alternate is extended with '<**>' (or variants '**>', '<**'). @@ -88,13 +88,13 @@ evaluation functions as semantic actions. @-pExpr :: Grammar Token Int-pExpr = \"Expr\" <::=> (-) '<$$>' pExpr '<**' 'keychar' \'-\' '<**>' pExpr- '<||>' (+) '<$$>' pExpr '<**' 'keychar' \'+\' '<**>' pExpr- '<||>' (*) '<$$>' pExpr '<**' 'keychar' \'*\' '<**>' pExpr- '<||>' div '<$$>' pExpr '<**' 'keychar' \'/\' '<**>' pExpr- '<||>' 'int_lit'- '<||>' parens pExpr+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 '**>' @@ -131,7 +131,7 @@ (use 'leftBiased' for the same effect globally). @-pExpr1 :: Grammar Token Int+pExpr1 :: BNF Token Int pExpr1 = \"Expr\" '<::=' ( (-) '<$$>' pExpr1 '<**' 'keychar' \'-\' '<**>' pExpr1 '<||>' (+) '<$$>' pExpr1 '<**' 'keychar' \'+\' '<**>' pExpr1 ) '<||>' ( (*) '<$$>' pExpr1 '<**' 'keychar' \'*\' '<**>' pExpr1@@ -161,7 +161,7 @@ The expression parser is written with chainl as follows: @-pExpr2 :: Grammar Token Int+pExpr2 :: BNF Token Int pExpr2 = pE1 where pE1 = chainl pE2 (\"E1\" '<::=>' (+) '<$$' 'keychar' \'+\' '<||>' (-) '<$$' 'keychar' \'-\') pE2 = chainl pE3 (\"E2\" '<::=>' (*) '<$$' 'keychar' \'*\' '<||>' div '<$$' 'keychar' \'/\')@@ -202,15 +202,16 @@ -- * Running a parser parse, -- ** Running a parser with options- parseWithOptions,+ parseWithOptions, parseWithParseOptions, -- *** Possible options CombinatorOptions, CombinatorOption, GLL.Combinators.Options.maximumErrors, throwErrors, maximumPivot, maximumPivotAtNt, -- **** Parser options- fullSPPF, allNodes, packedNodesOnly, strictBinarisation,+ fullSPPF, allNodes, packedNodesOnly, strictBinarisation, + GLL.Parser.noSelectTest, -- *** Running a parser with options and explicit failure- parseWithOptionsAndError,+ parseWithOptionsAndError, parseWithParseOptionsAndError, -- ** Runing a parser to obtain 'ParseResult'. parseResult, parseResultWithOptions,ParseResult(..), -- ** Builtin lexers.@@ -240,8 +241,8 @@ import GLL.Combinators.Visit.Join import GLL.Combinators.Memoisation import GLL.Combinators.Lexer-import GLL.Types.Abstract-import GLL.Parser hiding (parse, parseWithOptions, Options, Option, runOptions)+import GLL.Types.Grammar+import GLL.Parser hiding (parse, parseWithOptions) import qualified GLL.Parser as GLL import Control.Compose (OO(..))@@ -285,20 +286,36 @@ -- Run the parser with some 'CombinatorOptions'. parseWithOptions :: (Show t, Parseable t, IsSymbExpr s) => CombinatorOptions -> s t a -> [t] -> [a]-parseWithOptions opts p ts = - case parseWithOptionsAndError opts p ts of+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 = (\(_,_,t) -> t) . parse' defaultPOpts (runOptions opts) p+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@@ -416,8 +433,8 @@ -- | -- Apply a parser within two other parsers.-within :: BNF Char a -> BNF Char b -> BNF Char c -> BNF Char b-within l p r = mkRule $ l *> p <* r+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.@@ -500,7 +517,7 @@ -- * A 'MemoRef' pointing to a fresh 'MemoTable', created using 'newMemoTable'. -- * The 'SymbExpr' to memoise. ----- Use 'memo' on all parsers that are expected to derive the same +-- 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'. --@@ -677,8 +694,8 @@ in fresh <::=> Just <$$> p <||> satisfy Nothing -- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics.-within :: BNF Token a -> BNF Token b -> BNF Token c -> BNF Token b-within l p r = mkRule $ l **> p <** r+within :: IsSymbExpr s => BNF Token a -> s Token b -> BNF Token c -> BNF Token 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 ')')
src/GLL/Combinators/Lexer.hs view
@@ -3,7 +3,8 @@ default_lexer, lexer, LexerSettings(..), emptyLanguage, ) where -import GLL.Types.Abstract (Token(..), SubsumesToken(..))+import GLL.Types.Grammar (Token(..), SubsumesToken(..))+import Data.List (isPrefixOf) import Data.Char (isSpace, isDigit, isAlpha, isUpper, isLower) import Text.Regex.Applicative @@ -18,6 +19,10 @@ , whitespace :: Char -> Bool -- | How does a line comment start? Default: '"'//'"'. , lineComment :: String+ -- | How does a block comment open? Default: '"'{-'"'. + , blockCommentOpen :: String+ -- | How does a block comment close? Default: '"'-}'"'.+ , blockCommentClose :: String -- | How to recognise identifiers? Default alphanumerical with lowercase alpha start. , identifiers :: RE Char String -- | How to recognise alternative identifiers? Default alphanumerical with uppercase alpha start.@@ -28,7 +33,7 @@ -- | The default 'LexerSettings'. emptyLanguage :: LexerSettings-emptyLanguage = LexerSettings [] [] isSpace "//"+emptyLanguage = LexerSettings [] [] isSpace "//" "{-" "-}" ((:) <$> psym isLower <*> lowercase_id) ((:) <$> psym isUpper <*> lowercase_id) []@@ -41,14 +46,28 @@ -- | A lexer parameterised by 'LexerSettings'. lexer :: SubsumesToken t => LexerSettings -> String -> [t] lexer _ [] = []-lexer lexsets s =- let re = (Just <$> lTokens lexsets)- <|> (Nothing <$ some (psym (whitespace lexsets)))- <|> (Nothing <$ string (lineComment lexsets) <* many (psym ((/=) '\n')))- in case findLongestPrefix re s of- Just (Just tok, rest) -> tok : lexer lexsets rest- Just (Nothing,rest) -> lexer lexsets rest- Nothing -> error ("lexical error at: " ++ show (take 10 s))+lexer lexsets s+ | start /= "" && end /= "" && start `isPrefixOf` s = blockState 1 (drop lS s)+ | lComm /= "" && lComm `isPrefixOf` s = case dropWhile ((/=) '\n') s of+ [] -> []+ (c:cs) -> lexer lexsets cs+ | isWS (head s) = lexer lexsets (dropWhile isWS s)+ | otherwise = case findLongestPrefix (lTokens lexsets) s of+ Just (tok, rest) -> tok : lexer lexsets rest+ Nothing -> error ("lexical error at: " ++ show (take 10 s))+ where start = blockCommentOpen lexsets+ end = blockCommentClose lexsets+ isWS = whitespace lexsets+ lComm = lineComment lexsets+ lS = length start+ lE = length end++ blockState :: SubsumesToken t => Int -> String -> [t] + blockState n [] = [] + blockState 0 rest = lexer lexsets rest+ blockState n cs | start `isPrefixOf` cs = blockState (n+1) (drop lS cs)+ | end `isPrefixOf` cs = blockState (n-1) (drop lE cs) + | otherwise = blockState n (tail cs) lTokens :: SubsumesToken t => LexerSettings -> RE Char t lTokens lexsets =
src/GLL/Combinators/Options.hs view
@@ -11,6 +11,9 @@ , throw_errors :: Bool , do_memo :: Bool , max_errors :: Int+ , nt_select_test :: Bool+ , alt_select_test :: Bool+ , seq_select_test :: Bool } -- | A list of 'CombinatorOption's for evaluating combinator expressions.@@ -27,7 +30,7 @@ -- | The default options: no disambiguation. defaultOptions :: PCOptions-defaultOptions = PCOptions False Nothing False False False 3 +defaultOptions = PCOptions False Nothing False False False 3 True True True -- | Enables a 'longest-match' at production level. maximumPivot :: CombinatorOption@@ -91,4 +94,46 @@ where maintain xss = let (max,_):_ = maximumsWith (compare `on` fst) $ map head xss in (filter ((== max) . fst . head) xss)++-- | +-- Enables select tests at all levels: nonterminal, alternative and slot.+doSelectTest :: CombinatorOption+doSelectTest opts = opts { nt_select_test = True, alt_select_test = True+ , seq_select_test = True }++-- | +-- Disables select tests at all levels: nonterminal, alternative and slot.+noSelectTest :: CombinatorOption+noSelectTest opts = opts { nt_select_test = False, alt_select_test = False+ , seq_select_test = False }++-- | +-- Enables select tests at the level of alternatives+doAltSelectTest :: CombinatorOption+doAltSelectTest opts = opts { alt_select_test = True }++-- | +-- Disables select tests at the level of alternatives+noAltSelectTest :: CombinatorOption+noAltSelectTest opts = opts { alt_select_test = False }++-- | +-- Enables select tests at the level of nonterminals+doNtSelectTest :: CombinatorOption+doNtSelectTest opts = opts { nt_select_test = True }++-- | +-- Disables select tests at the level of nonterminals+noNtSelectTest :: CombinatorOption+noNtSelectTest opts = opts { nt_select_test = False }++-- | +-- Enables select tests at the level of grammar slots+doSlotSelectTest :: CombinatorOption+doSlotSelectTest opts = opts { seq_select_test = True }++-- | +-- Disables select tests at the level of grammar slots+noSlotSelectTest :: CombinatorOption+noSlotSelectTest opts = opts { seq_select_test = False }
src/GLL/Combinators/Visit/Grammar.hs view
@@ -1,7 +1,7 @@ module GLL.Combinators.Visit.Grammar where -import GLL.Types.Abstract+import GLL.Types.Grammar import qualified Data.Map as M
src/GLL/Combinators/Visit/Join.hs view
@@ -2,8 +2,8 @@ module GLL.Combinators.Visit.Join where +import GLL.Types.Derivations import GLL.Types.Grammar-import GLL.Types.Abstract import GLL.Combinators.Visit.Sem import GLL.Combinators.Visit.Grammar import GLL.Combinators.Options
src/GLL/Combinators/Visit/Sem.hs view
@@ -2,8 +2,8 @@ module GLL.Combinators.Visit.Sem where import GLL.Combinators.Options-import GLL.Types.Abstract import GLL.Types.Grammar+import GLL.Types.Derivations import Control.Monad (forM) import qualified Data.Array as A
+ src/GLL/Flags.hs view
@@ -0,0 +1,65 @@++module GLL.Flags where++-- | Flags to influence the behaviour of the parser.+data Flags = Flags { symbol_nodes :: Bool+ , intermediate_nodes :: Bool+ , edges :: Bool+ , flexible_binarisation :: Bool+ , max_errors :: Int+ , do_select_test :: Bool+ }++-- | The default flags:+-- * Do not add symbol nodes to the 'SPPF'.+-- * Do not add intermediate nodes to the 'SPPF'.+-- * Do not add edges to the 'SPPF'.+-- * Flexible binarisation.+-- * The three furthest discoveries of a token mismatch are reported. +-- * Select tests are performed.+defaultFlags = Flags False False False True 3 True++-- | Execute the given 'Options' in left-to-right order on 'defaultFlags'.+runOptions :: ParseOptions -> Flags+runOptions = foldr ($) defaultFlags++-- | An option updates the current set of 'Flags'.+type ParseOption = Flags -> Flags++-- | A list of 'ParserOption's+type ParseOptions = [ParseOption]++-- | +-- Create the 'SPPF' with all nodes and edges, not necessarily strictly binarised.+fullSPPF :: ParseOption+fullSPPF flags = flags{symbol_nodes = True, intermediate_nodes = True, edges = True}++-- |+-- Create all nodes, but no edges between nodes.+allNodes :: ParseOption+allNodes flags = flags{symbol_nodes = True, intermediate_nodes = True}++-- | +-- Create packed-nodes only.+packedNodesOnly :: ParseOption+packedNodesOnly flags = flags{symbol_nodes = False, intermediate_nodes = False, edges = False}++-- | +-- Fully binarise the SPPF, resulting in a larger 'SPPF' and possibly slower runtimes.+-- When this flag is on, packed nodes can only have a single symbol node child +-- or one intermediate node child and one symbol node child.+-- With the flag disabled a packed node can have two symbol node children.+strictBinarisation :: ParseOption+strictBinarisation flags = flags{flexible_binarisation = False}++-- | +-- Set the maximum number of errors shown in case of an unsuccessful parse.+maximumErrors :: Int -> ParseOption+maximumErrors n flags = flags {max_errors = n}++-- |+-- Turn of select tests. Disables lookahead.+noSelectTest :: ParseOption+noSelectTest flags = flags{do_select_test = False}++
src/GLL/Parseable/Char.hs view
@@ -3,7 +3,7 @@ -- that assumes '$' and '#' never appear in the inpur string. module GLL.Parseable.Char () where -import GLL.Types.Abstract+import GLL.Types.Grammar -- | Assumes '$' and '#' never appear in the inpur string. instance Parseable Char where
src/GLL/Parser.hs view
@@ -1,12 +1,12 @@ {-|-Implementation of the GLL parsing algorithm [Scott and Johnstone 2010,2013]+Implementation of the GLL parsing algorithm [Scott and Johnstone 2010,2013,2016] with the grammar as an explicit parameter. Function 'parse' receives a 'Grammar' as input together with a list of tokens (the input string). -The type of token is chosen arbitrarily, but the type should be 'Parseable' and orderable.+The type of token is chosen arbitrarily, but the type should be 'Parseable' and 'Ord'erable. To be 'Parseable' a type must have two distinct values, 'eos' (end-of-string) and 'eps' (epsilon). The user must ensure that these two values will never occur as part of the input string.@@ -143,17 +143,16 @@ The options 'fullSPPF', 'allNodes', 'packedNodesOnly', decide whether all SPPF nodes and edges are inserted into the resulting value of the 'SPPF' type. Packed nodes are enough to fully represent an SPPF, as the parent and children-of a packed node can be computed from the packed nodes' information (given that the -packed node stores the left and right extent of its parent).+of a packed node can be computed from the packed nodes' information. For efficiency the 'SPPF' is not strictly binarised by default: a packed node might have a symbol node as a left child. In a strictly binarised 'SPPF' a packed node has an intermediate node as a left child, or no left child at all.-To create a strictly binarised 'SPPF' (necessary for "GLL.Combinators") to option+To create a strictly binarised 'SPPF' (necessary for "GLL.Combinators") the option 'strictBinarisation' is available. === Combinator interface Module "GLL.Combinators.Interface" provides a combinator interface to access-"GLL.Parser". Applicative-like combinators are used to extract a 'Grammar' and+"GLL.Parser". Applicative-like combinators are used to specify a 'Grammar' and call 'parse'. The 'SPPF' is then used to produce semantic results. -}@@ -171,12 +170,13 @@ -- *** ParseOptions ParseOptions, ParseOption, strictBinarisation, fullSPPF, allNodes, packedNodesOnly, maximumErrors,+ noSelectTest, -- ** Result ParseResult(..), SPPF(..), SPPFNode(..), SymbMap, ImdMap, PackMap, EdgeMap, showSPPF, ) where import Data.Foldable hiding (forM_, toList, sum)-import Prelude hiding (lookup, foldr, fmap, foldl, elem, any)+import Prelude hiding (lookup, foldr, fmap, foldl, elem, any, concatMap) import Control.Applicative import Control.Monad import qualified Data.IntMap as IM@@ -187,8 +187,9 @@ import Data.Text (pack) import Text.PrettyPrint.HughesPJ as PP -import GLL.Types.Abstract import GLL.Types.Grammar+import GLL.Types.Derivations+import GLL.Flags -- | Create an 'Nt' (nonterminal) from a String. string2nt :: String -> Nt@@ -214,24 +215,22 @@ type Input t = A.Array Int t -- | Types for -type LhsParams t = (Nt , Int , GSSNode t)-type RhsParams t = (Slot t , Int , GSSNode t)+type LhsParams t = (Nt, Int)+type RhsParams t = (Slot t, Int, Int) -- | The worklist and descriptor set type Rcal t = [(RhsParams t, SPPFNode t)]-type Ucal t = IM.IntMap (IM.IntMap (S.Set (Slot t, GSlot t)))+type Ucal t = IM.IntMap (IM.IntMap (S.Set (Slot t))) -- | GSS representation-type GSS t = IM.IntMap (M.Map (GSlot t) [GSSEdge t])-type GSSEdge t = (GSSNode t, SPPFNode t)-type GSSNode t = (GSlot t, Int)-data GSlot t = GSlot (Slot t)- | U0 - deriving (Ord, Eq) +type GSS t = IM.IntMap (M.Map Nt [GSSEdge t])+type GSSEdge t = (Slot t, Int, SPPFNode t) -- return position, left extent+type GSSNode t = (Nt, Int)+ type MisMatches t = IM.IntMap (S.Set t) -- | Pop-set-type Pcal t = IM.IntMap (M.Map (GSlot t) [Int])+type Pcal t = IM.IntMap (M.Map Nt [Int]) -- | Connecting it all data Mutable t = Mutable { mut_success :: Bool@@ -256,14 +255,14 @@ pMapInsert f t (mut_sppf mut) in ((),mut{mut_sppf = sppf'}) -addDescr sppf alt@(slot,i,(gs,l)) = GLL $ \_ mut -> +addDescr sppf alt@(slot,i,l) = GLL $ \_ mut -> let new = maybe True inner $ IM.lookup i (mut_descriptors mut)- where inner m = maybe True (not . ((slot,gs) `S.member`)) $ IM.lookup l m+ where inner m = maybe True (not . (slot `S.member`)) $ IM.lookup l m newU = IM.alter inner i (mut_descriptors mut) 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,gs)+ single = S.singleton slot in if new then ((), mut{mut_worklist = (alt,sppf):(mut_worklist mut) ,mut_descriptors = newU}) else ((), mut)@@ -308,10 +307,6 @@ | otherwise = newM in ((), mut{mut_mismatches = newM'}) -instance (Show t) => Show (GSlot t) where- show (U0) = "u0"- show (GSlot gn) = show gn- instance (Show t) => Show (SPPFNode t) where show (SNode (s, l, r)) = "(s: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")" show (INode (s, l, r)) = "(i: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")"@@ -329,61 +324,7 @@ (GLL m') = f a in m' o p' --- | Flags to influence the behaviour of the parser.-data Flags = Flags { symbol_nodes :: Bool- , intermediate_nodes :: Bool- , edges :: Bool- , flexible_binarisation :: Bool- , max_errors :: Int- }---- | The default flags:--- * Do not add symbol nodes to the 'SPPF'.--- * Do not add intermediate nodes to the 'SPPF'.--- * Do not add edges to the 'SPPF'.--- * Flexible binarisation.--- * The three furthest discoveries of a token mismatch are reported. -defaultFlags = Flags False False False True 3---- | Execute the given 'Options' in left-to-right order on 'defaultFlags'.-runOptions :: ParseOptions -> Flags-runOptions = foldr ($) defaultFlags---- | An option updates the current set of 'Flags'.-type ParseOption = Flags -> Flags---- | A list of 'ParserOption's-type ParseOptions = [ParseOption]- -- | --- Create the 'SPPF' with all nodes and edges, not necessarily strictly binarised.-fullSPPF :: ParseOption-fullSPPF flags = flags{symbol_nodes = True, intermediate_nodes = True, edges = True}---- |--- Create all nodes, but no edges between nodes.-allNodes :: ParseOption-allNodes flags = flags{symbol_nodes = True, intermediate_nodes = True}---- | --- Create packed-nodes only.-packedNodesOnly :: ParseOption-packedNodesOnly flags = flags{symbol_nodes = False, intermediate_nodes = False, edges = False}---- | --- Fully binarise the SPPF, resulting in a larger 'SPPF' and possibly slower runtimes.--- When this flag is on, packed nodes can only have a single symbol node child --- or one intermediate node child and one symbol node child.--- With the flag disabled a packed node can have two symbol node children.-strictBinarisation :: ParseOption-strictBinarisation flags = flags{flexible_binarisation = False}---- | --- Set the maximum number of errors shown in case of an unsuccessful parse.-maximumErrors :: Int -> ParseOption-maximumErrors n flags = flags {max_errors = n}---- | -- Run the GLL parser given a 'Grammar' 't' and a list of 't's, -- where 't' is an arbitrary token-type. -- All token-types must be 'Parseable'.@@ -400,17 +341,16 @@ parseWithOptions :: Parseable t => ParseOptions -> Grammar t -> [t] -> ParseResult t parseWithOptions opts grammar@(start,_) str = let flags = runOptions opts- (mutable,_,_,_) = gll flags m False grammar input+ (mutable,_,_) = gll flags m False grammar input m = length str input = A.array (0,m) $ zip [0..] $ str ++ [eos] in resultFromMutable input flags mutable (Nt start, 0, m) gll :: Parseable t => Flags -> Int -> Bool -> Grammar t -> Input t -> - (Mutable t, [Prod t], SelectMap t, FollowMap t)+ (Mutable t, SelectMap t, FollowMap t) gll flags m debug (start, prods) input = - (runGLL (pLhs (start, 0, (U0,0))) flags context, prs, selects, follows)+ (runGLL (pLhs (start, 0)) flags context, selects, follows) where - prs = [ alt | alt <- (reverse prods) ] context = Mutable False emptySPPF [] IM.empty IM.empty IM.empty IM.empty dispatch = do@@ -419,8 +359,8 @@ Nothing -> return () -- no continuation Just (next,sppf) -> pRhs next sppf - pLhs (bigx, i, gn) = do - let alts = [ ((Slot bigx [] beta, i, gn), first_ts) + pLhs (bigx, i) = do + let alts = [ ((Slot bigx [] beta, i, i), first_ts) | Prod bigx beta <- altsOf bigx , let first_ts = select beta bigx ]@@ -432,54 +372,59 @@ else forM_ cands (addDescr Dummy) dispatch - pRhs (Slot bigx alpha ((Term tau):beta), i, (gs,l)) sppf = + pRhs (Slot bigx alpha ((Term tau):beta), i, l) sppf = if (input A.! i `matches` tau) - then do -- token test + then do -- token test successful root <- joinSPPFs slot sppf l i (i+1) - pRhs (slot, i+1, (gs,l)) root + pRhs (slot, i+1, l) root else do addMisMatch i (S.singleton tau) dispatch where slot = Slot bigx (alpha++[Term tau]) beta - pRhs (Slot bigx alpha ((Nt bigy):beta), i, (gs, l)) sppf = + pRhs (Slot bigx alpha ((Nt bigy):beta), i, l) sppf = if any (matches (input A.! i)) first_ts then do- addGSSEdge ret ((gs,l), sppf) + addGSSEdge ret (slot,l,sppf) rs <- getPops ret -- has ret been popped? forM_ rs $ \r -> do -- yes, use given extents root <- joinSPPFs slot sppf l i r- addDescr root (slot, r, (gs,l))- pLhs (bigy, i, ret)+ addDescr root (slot, r, l)+ pLhs (bigy, i) else do addMisMatch i first_ts dispatch- where ret = (GSlot slot, i)+ where ret = (bigy, i) slot = Slot bigx (alpha++[Nt bigy]) beta first_ts = select ((Nt bigy):beta) bigx - pRhs (Slot bigy alpha [], i, (U0,_)) sppf = do- when (bigy /= start) (error "assert: start symbol with U0") + pRhs (Slot bigy alpha [], i, l) sppf | bigy == start && l == 0 = if i == m - then addSuccess >> dispatch - else addMisMatch i (S.singleton eos) >> dispatch+ then addSuccess >> dispatch + else addMisMatch i (S.singleton eos) >> dispatch - pRhs (Slot bigx alpha [], i, (gs,l)) Dummy = do+ pRhs (Slot bigx alpha [], i, l) Dummy = do root <- joinSPPFs slot Dummy l i i- pRhs (slot, i, (gs,l)) root+ pRhs (slot, i, l) root where slot = Slot bigx [] [] - pRhs (Slot bigy alpha [], i, gn@(GSlot slot,l)) ynode = do- addPop gn i- returns <- getChildren gn- forM_ returns $ \((gs',l'),sppf) -> do - root <- joinSPPFs slot sppf l' l i -- create SPPF for lhs- addDescr root (slot, i, (gs',l')) -- add new descriptors+ pRhs (Slot bigy alpha [], i, l) ynode = do+ addPop (bigy,l) i+ returns <- getChildren (bigy,l) + forM_ returns $ \(gs',l',sppf) -> do + root <- joinSPPFs gs' sppf l' l i -- create SPPF for lhs+ addDescr root (gs', i, l') -- add new descriptors dispatch - (prodMap,_,_,follows,selects) = fixedMaps start prs+ (prodMap,_,_,follows,selects) + | do_select_test flags = fixedMaps start prods + | otherwise = (pmap, undefined, undefined, undefined, + 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 altsOf x = prodMap M.! x merge m1 m2 = IM.unionWith inner m1 m2 where inner = IM.unionWith S.union
− src/GLL/Types/Abstract.hs
@@ -1,159 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}----- UUAGC 0.9.52.1 (src/GLL/Types/Abstract.ag)-module GLL.Types.Abstract where--import Data.Text-{-# LINE 1 "src/GLL/Types/Abstract.ag" #-}--{-# LINE 12 "dist/build/GLL/Types/Abstract.hs" #-}---- | Identifier for nonterminals.-type Nt = Text --- Prod ------------------------------------------------------------- | --- A production binds a nonterminal identifier (left-hand side) to a list of symbols ---(the right-hand side of the production).-data Prod t = Prod (Nt) (Symbols t)--- Prods ----------------------------------------------------------- | A list of 'Prod's.-type Prods t = [Prod t]--- Grammar -------------------------------------------------------- |--- A grammar is a start symbol and a list of productions. -type Grammar t = (Nt, Prods t)--- Slot ----------------------------------------------------------- | --- A grammar slot acts as a label to identify progress of matching a production.--- As such, a slot is a "Prod" with its right-hand side split in two: --- a part before and a part after 'the dot'.--- The dot indicates which part of the right-hand side has been processed thus far.-data Slot t = Slot (Nt) (([Symbol t])) (([Symbol t]))--- Symbol ---------------------------------------------------------- | --- A 'Symbol' is either a nonterminal or a terminal,--- where a terminal contains some arbitrary token.-data Symbol t = Nt Nt- | Term t--- | Error (Token) (Token)--- Symbols --------------------------------------------------------- | --- A list of 'Symbol's-type Symbols t = [Symbol t]--- Token ----------------------------------------------------------- |--- A datatype for representing tokens with some builtins --- and an aribitrary Token constructor.--- This datatype stores (optional) lexemes.-data Token = Char Char- | Keyword String- | EOS- | Epsilon- | IntLit (Maybe Int)- | BoolLit (Maybe Bool)- | StringLit (Maybe String)- | CharLit (Maybe Char)- | IDLit (Maybe String)- -- | alternative identifiers, for example functions vs. constructors (as in Haskell).- | AltIDLit (Maybe String) - | Token String (Maybe String)--- Tokens --------------------------------------------------------- | --- A list of 'Token's-type Tokens = [Token]---- | Class that captures elements of an input string (tokens).--- --- * 'eos' is the end-of-string symbol --- * 'eps' is the empty-string symbol------ Both 'eos' and 'eps' must be distinct from eachother and from all --- tokens in the input string.--- The show instance is required to throw error messages.-class (Ord a, Eq a, Show a) => Parseable a where- eos :: a- eps :: a -- -- | This function is used for matching grammar tokens and input tokens.- -- Override this method if, for example, your input tokens store lexemes- -- while the grammar tokens do not- matches :: a -> a -> Bool-- -- | This function pretty-prints the Parseable type by displaying its lexeme.- -- Default implementation is 'show', which should be replaced for prettier error messages.- unlex :: a -> String- unlex = show---- | Class whose members are super-types of 'Token'.-class SubsumesToken a where- upcast :: Token -> a- downcast :: a -> Maybe Token--instance SubsumesToken Token where- upcast = id- downcast = Just . id--deriving instance Ord Token-deriving instance Eq Token--instance Show Token where- show (Char c) = "char('" ++ [c] ++ "')"- show (Keyword s) = "keyword(\"" ++ s ++ "\")"- show (EOS) = "<end-of-string>"- show (Epsilon) = "<epsilon>"- show (IntLit (Just i)) = "int(" ++ show i ++ ")"- show (IntLit _) = "<int>"- show (BoolLit (Just b)) = "bool(" ++ show b ++ ")"- show (BoolLit _) = "<bool>"- show (StringLit (Just s)) = "string(\"" ++ s ++ "\")"- show (StringLit _) = "<string>"- show (CharLit (Just c)) = "char-literal('" ++ [c] ++ "')"- show (CharLit Nothing) = "<char>"- show (AltIDLit (Just id)) = "altid(\"" ++ id ++ "\")"- show (AltIDLit Nothing) = "<altid>"- show (IDLit (Just id)) = "id(\"" ++ id ++ "\")"- show (IDLit Nothing) = "<id>"- show (Token nm (Just s)) = nm ++ "(\"" ++ s ++ "\")"- show (Token nm _) = "<" ++ nm ++ ">"- -instance Parseable Token where- eos = EOS- eps = Epsilon-- unlex = unlexToken-- Token k _ `matches` Token k' _ = k' == k- Char c `matches` Char c' = c' == c- Keyword k `matches` Keyword k' = k' == k- EOS `matches` EOS = True- Epsilon `matches` Epsilon = True- StringLit _ `matches` StringLit _ = True- CharLit _ `matches` CharLit _ = True- IntLit _ `matches` IntLit _ = True- BoolLit _ `matches` BoolLit _ = True- AltIDLit _ `matches` AltIDLit _ = True- IDLit _ `matches` IDLit _ = True- _ `matches` _ = False----- | Pretty-prints a list of 'Token's as a concatenation of their lexemes.-unlexTokens :: [Token] -> String-unlexTokens = Prelude.concatMap unlexToken --unlexToken :: Token -> String-unlexToken t = case t of - Char c -> [c]- Keyword s -> s- IntLit (Just i) -> show i- BoolLit (Just b) -> show b- StringLit (Just s) -> s- CharLit (Just c) -> [c]- AltIDLit (Just s) -> s- IDLit (Just s) -> s- Token _ (Just s) -> s- _ -> ""
+ src/GLL/Types/Derivations.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE StandaloneDeriving #-}++module GLL.Types.Derivations where++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++-- 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++-- SPPF++-- | +-- An 'SPPF' contains symbol nodes, intermediate nodes, packed nodes and edges between them.+-- See Scott and Johnstone (2013) for an explanation of the 'SPPF'.+type SPPF t = (SymbMap t, ImdMap t, PackMap t, EdgeMap t)++-- | +-- 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 PackMap t = IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))++-- | +-- Stores symbol nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * set of symbols+type SymbMap t = IM.IntMap (IM.IntMap (S.Set (Symbol t)))++-- | +-- Stores intermediate nodes using nested "Data.IntMap"s, nesting is as follows:+--+-- * left extent+-- * right extent+-- * set of slots +type ImdMap t = IM.IntMap (IM.IntMap (S.Set (Slot t)))++-- | +-- Stores edges, potentially costly.+type EdgeMap t = M.Map (SPPFNode t) (S.Set (SPPFNode t))++-- | +-- An "SPPFNode" is either a symbol node, an intermediate node, a packed node or a dummy.+data SPPFNode t = SNode (Symbol t, Int, Int) + | INode (Slot t, Int, Int)+ | PNode (Slot t, Int, Int, Int)+ | Dummy+ deriving (Ord, Eq)++type SNode t = (Symbol t, Int, Int)+type PNode t = (Prod t, [Int])+type SEdge t = M.Map (SNode t)(S.Set (PNode t))+type PEdge t = M.Map (PNode t) (S.Set (SNode t))++emptySPPF :: (Ord t) => SPPF t+emptySPPF = (IM.empty, IM.empty, IM.empty, M.empty)++pNodeLookup :: (Ord t) => SPPF 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++pMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+pMapInsert f t (sMap,iMap,pMap,eMap) = + let pMap' = case f of + PNode ((Slot x alpha beta), l, k, r) -> + add (Prod x (alpha++beta)) (length alpha) l r k+ _ -> pMap+ in (sMap,iMap,pMap',eMap)+ 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+++sNodeLookup :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> Bool +sNodeLookup (sm,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l sm+ where inner = maybe False (S.member s) . IM.lookup r++sNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+sNodeInsert f t (sMap,iMap,pMap,eMap) = + let sMap' = case f of+ SNode (s, l, r) -> newt (add s l r sMap)+ _ -> newt sMap+ in (sMap',iMap,pMap,eMap)+ where newt sMap = case t of + (SNode (s, l, r)) -> add s l r sMap+ _ -> sMap+ add s l r sMap = IM.alter addInnerL l sMap+ where addInnerL mm = case mm of + Nothing -> Just singleRS+ Just m -> Just $ IM.insertWith (S.union) r singleS m+ singleRS = IM.fromList [(r, singleS)]+ singleS = S.singleton s+ +sNodeRemove :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> SPPF t+sNodeRemove (sm,iMap,pMap,eMap) (s,l,r) = + (IM.adjust inner l sm, iMap,pMap,eMap)+ where inner = IM.adjust ((s `S.delete`)) r++iNodeLookup :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> Bool +iNodeLookup (_,iMap,_,_) (s,l,r) = maybe False inner $ IM.lookup l iMap+ where inner = maybe False (S.member s) . IM.lookup r++iNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+iNodeInsert f t (sMap,iMap,pMap,eMap) = + let iMap' = case f of+ INode (s, l, r) -> newt (add s l r iMap)+ _ -> newt iMap+ in (sMap,iMap',pMap,eMap)+ where newt iMap = case t of + (INode (s, l, r)) -> add s l r iMap+ _ -> iMap+ add s l r iMap = IM.alter addInnerL l iMap+ where addInnerL mm = case mm of + Nothing -> Just singleRS+ Just m -> Just $ IM.insertWith (S.union) r singleS m+ singleRS = IM.fromList [(r, singleS)]+ singleS = S.singleton s+ +iNodeRemove :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> SPPF t+iNodeRemove (sMap,iMap,pMap,eMap) (s,l,r) = + (sMap,IM.adjust inner l iMap,pMap,eMap)+ where inner = IM.adjust ((s `S.delete`)) r++eMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t+eMapInsert f t (sMap,iMap,pMap,eMap) = + (sMap,iMap,pMap,M.insertWith (S.union) f (S.singleton t) eMap)++-- helpers for Ucal+inU (slot,l,i) u = maybe False inner $ IM.lookup l u+ where inner = maybe False (S.member slot) . IM.lookup i++toU (slot,l,i) u = IM.alter inner l u+ where inner mm = case mm of+ Nothing -> Just $ singleIS+ Just m -> Just $ IM.insertWith S.union i singleS m+ singleIS = IM.fromList [(i,singleS)]+ singleS = S.singleton slot+++showD dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]+showG dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]+showP 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 ]+showS sMap = unlines [ show (l,r) ++ " --> " ++ show (sset)+ | (l,r2s) <- IM.assocs sMap, (r,sset) <- IM.assocs r2s]++showSPPF :: Show t => SPPF t -> String +showSPPF (_,_,pMap,_) = showP pMap ++type ProdMap t = M.Map Nt [Prod t]+type PrefixMap t = M.Map (Prod t,Int) ([t], Maybe Nt)+type SelectMap t = M.Map (Nt, [Symbol t]) (S.Set t)+type FirstMap t = M.Map Nt (S.Set t)+type FollowMap t = M.Map Nt (S.Set t)++fixedMaps :: (Eq t, Ord t, Parseable t) => Nt -> [Prod t] -> + (ProdMap t, PrefixMap t, FirstMap t, FollowMap t, SelectMap t) +fixedMaps s prs = (prodMap, prefixMap, firstMap, followMap, selectMap)+ where+ prodMap = M.fromListWith (++) [ (x,[pr]) | pr@(Prod x _) <- prs ]++ prefixMap = M.fromList + [ ((pr,j), (tokens,msymb)) | pr@(Prod x alpha) <- prs+ , (j,tokens,msymb) <- prefix x alpha ]+ where+ prefix x alpha = map rangePrefix ranges+ where js = (map ((+) 1) (findIndices isNt alpha))+ ranges = zip (0:js) (js ++ [length alpha])+ rangePrefix (a,z) | a >= z = (a,[],Nothing)+ rangePrefix (a,z) = + let init = map ((\(Term t) -> t) . (alpha !!)) [a .. (z-2)]+ last = alpha !! (z-1)+ in case last of + Nt nt -> (a,init, Just nt)+ Term t -> (a,init ++ [t], Nothing)++ firstMap = M.fromList [ (x, first_x [] x) | x <- M.keys prodMap ]++ first_x ys x = S.unions [ first_alpha (x:ys) rhs | Prod _ rhs <- prodMap M.! x ]+ + selectMap = M.fromList [ ((x,alpha), select alpha x) | Prod x rhs <- prs+ , alpha <- split rhs ]+ where+ split rhs = foldr op [] js+ where op j acc = drop j rhs : acc+ js = 0 : findIndices isNt rhs++ -- TODO store intermediate results+ select alpha x = res + where firsts = first_alpha [] alpha+ res | eps `S.member` firsts = S.delete eps firsts `S.union` (followMap M.! x)+ | otherwise = firsts++ -- list of symbols to get firsts from + non-terminal to ignore+ -- TODO store in map+ first_alpha ys [] = S.singleton eps + first_alpha ys (x:xs) = + case x of+ Term tau -> if tau == eps then first_alpha ys xs+ else S.singleton tau+ Nt x -> + let fs | x `elem` ys = S.empty + | otherwise = first_x (x:ys) x+ in if x `S.member` nullableSet+ then S.delete eps fs `S.union` first_alpha (x:ys) xs+ else fs++ followMap = M.fromList [ (x, follow [] x) | x <- M.keys prodMap ] + + follow ys x = S.unions (map fw (maybe [] id $ M.lookup x localMap))+ `S.union` (if x == s then S.singleton eos else S.empty)+ where fw (y,ss) = + let ts = S.delete eps (first_alpha [] ss)+ fs = follow (x:ys) y + in if nullable_alpha [] ss && not (x `elem` (y:ys))+ then ts `S.union` fs + else ts++ localMap = M.fromListWith (++)+ [ (x,[(y,tail)]) | x <- M.keys prodMap, (Prod y rhs) <- prs+ , tail <- tails x rhs ]+ where+ tails x symbs = [ drop (index + 1) symbs | index <- indices ]+ where indices = elemIndices (Nt x) symbs+ + nullableSet :: S.Set Nt+ nullableSet = S.fromList $ [ x | x <- M.keys prodMap, nullable_x [] x ]++ -- a nonterminal is nullable if any of its alternatives is empty + nullable_x :: [Nt] -> Nt -> Bool+ nullable_x ys x = or [ nullable_alpha (x:ys) rhs + | (Prod _ rhs) <- prodMap M.! x ] ++ -- TODO store in map+ nullable_alpha :: [Nt] -> [Symbol t] -> Bool+ nullable_alpha ys [] = True+ nullable_alpha ys (s:ss) = + case s of+ Nt nt -> if nt `elem` ys + then False --nullable only if some other alternative is nullable+ else nullable_x ys nt && nullable_alpha (nt:ys) ss+ otherwise -> False++{-+instance Show Symbol where+ show (Nt nt) = "Nt " ++ show nt+ show (Term t) = "Term " ++ show t+ show (Error t1 t2) = "Error " ++ show t1 ++ " " ++ show t2++instance Eq Symbol where+ (Nt nt) == (Nt nt') = nt == nt'+ (Term t) == (Term t') = t == t'+ (Error t1 t2) == (Error t1' t2') = (t1,t2) == (t1',t2')++instance Ord Symbol where+ (Nt nt) `compare` (Nt nt') = nt `compare` nt+ (Nt _) `compare` _ = LT+ _ `compare` (Nt _) = GT+ (Term t) `compare` (Term t') = t `compare` t'+ (Term _) `compare` _ = LT+ _ `compare` (Term _) = GT+ (Error t1 t2) `compare` (Error t1' t2') = (t1,t2) `compare` (t1',t2')+-}++
src/GLL/Types/Grammar.hs view
@@ -1,314 +1,168 @@ {-# LANGUAGE StandaloneDeriving #-} -module GLL.Types.Grammar where -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.Abstract---- 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+-- UUAGC 0.9.52.1 (src/GLL/Types/Abstract.ag)+module GLL.Types.Grammar where --- SPPF+import Data.Text --- | --- An 'SPPF' contains symbol nodes, intermediate nodes, packed nodes and edges between them.--- See Scott and Johnstone (2013) for an explanation of the 'SPPF'.-type SPPF t = (SymbMap t, ImdMap t, PackMap t, EdgeMap t)+-- | Identifier for nonterminals.+type Nt = Text +-- Prod --------------------------------------------------------- -- | --- 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 PackMap t = IM.IntMap (IM.IntMap (IM.IntMap (M.Map (Prod t) IS.IntSet)))-+-- A production binds a nonterminal identifier (left-hand side) to a list of symbols +--(the right-hand side of the production).+data Prod t = Prod (Nt) (Symbols t)+-- Prods --------------------------------------------------------+-- | A list of 'Prod's.+type Prods t = [Prod t]+-- Grammar -----------------------------------------------------+-- |+-- A grammar is a start symbol and a list of productions. +type Grammar t = (Nt, Prods t)+-- Slot -------------------------------------------------------- -- | --- Stores symbol nodes using nested "Data.IntMap"s, nesting is as follows:------ * left extent--- * right extent--- * set of symbols-type SymbMap t = IM.IntMap (IM.IntMap (S.Set (Symbol t)))+-- A grammar slot acts as a label to identify progress of matching a production.+-- As such, a slot is a "Prod" with its right-hand side split in two: +-- a part before and a part after 'the dot'.+-- The dot indicates which part of the right-hand side has been processed thus far.+data Slot t = Slot (Nt) (([Symbol t])) (([Symbol t]))+-- Symbol ------------------------------------------------------ -- | --- Stores intermediate nodes using nested "Data.IntMap"s, nesting is as follows:------ * left extent--- * right extent--- * set of slots -type ImdMap t = IM.IntMap (IM.IntMap (S.Set (Slot t)))+-- A 'Symbol' is either a nonterminal or a terminal,+-- where a terminal contains some arbitrary token.+data Symbol t = Nt Nt+ | Term t+-- | Error (Token) (Token)+-- Symbols ----------------------------------------------------- -- | --- Stores edges, potentially costly.-type EdgeMap t = M.Map (SPPFNode t) (S.Set (SPPFNode t))+-- A list of 'Symbol's+type Symbols t = [Symbol t]+-- Token ------------------------------------------------------- +-- |+-- A datatype for representing tokens with some builtins +-- and an aribitrary Token constructor.+-- This datatype stores (optional) lexemes.+data Token = Char Char+ | Keyword String+ | EOS+ | Epsilon+ | IntLit (Maybe Int)+ | BoolLit (Maybe Bool)+ | StringLit (Maybe String)+ | CharLit (Maybe Char)+ | IDLit (Maybe String)+ -- | alternative identifiers, for example functions vs. constructors (as in Haskell).+ | AltIDLit (Maybe String) + | Token String (Maybe String)+-- Tokens ------------------------------------------------------ -- | --- An "SPPFNode" is either a symbol node, an intermediate node, a packed node or a dummy.-data SPPFNode t = SNode (Symbol t, Int, Int) - | INode (Slot t, Int, Int)- | PNode (Slot t, Int, Int, Int)- | Dummy- deriving (Ord, Eq)--type SNode t = (Symbol t, Int, Int)-type PNode t = (Prod t, [Int])-type SEdge t = M.Map (SNode t)(S.Set (PNode t))-type PEdge t = M.Map (PNode t) (S.Set (SNode t))--emptySPPF :: (Ord t) => SPPF t-emptySPPF = (IM.empty, IM.empty, IM.empty, M.empty)--pNodeLookup :: (Ord t) => SPPF 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+-- A list of 'Token's+type Tokens = [Token] -pMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t-pMapInsert f t (sMap,iMap,pMap,eMap) = - let pMap' = case f of - PNode ((Slot x alpha beta), l, k, r) -> - add (Prod x (alpha++beta)) (length alpha) l r k- _ -> pMap- in (sMap,iMap,pMap',eMap)- 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+-- | Class that captures elements of an input string (tokens).+-- +-- * 'eos' is the end-of-string symbol +-- * 'eps' is the empty-string symbol+--+-- Both 'eos' and 'eps' must be distinct from eachother and from all +-- tokens in the input string.+-- The show instance is required to throw error messages.+class (Ord a, Eq a, Show a) => Parseable a where+ eos :: a+ eps :: a + -- | This function is used for matching grammar tokens and input tokens.+ -- Override this method if, for example, your input tokens store lexemes+ -- while the grammar tokens do not+ matches :: a -> a -> Bool -sNodeLookup :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> Bool -sNodeLookup (sm,_,_,_) (s,l,r) = maybe False inner $ IM.lookup l sm- where inner = maybe False (S.member s) . IM.lookup r+ -- | This function pretty-prints the Parseable type by displaying its lexeme.+ -- Default implementation is 'show', which should be replaced for prettier error messages.+ unlex :: a -> String+ unlex = show -sNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t-sNodeInsert f t (sMap,iMap,pMap,eMap) = - let sMap' = case f of- SNode (s, l, r) -> newt (add s l r sMap)- _ -> newt sMap- in (sMap',iMap,pMap,eMap)- where newt sMap = case t of - (SNode (s, l, r)) -> add s l r sMap- _ -> sMap- add s l r sMap = IM.alter addInnerL l sMap- where addInnerL mm = case mm of - Nothing -> Just singleRS- Just m -> Just $ IM.insertWith (S.union) r singleS m- singleRS = IM.fromList [(r, singleS)]- singleS = S.singleton s- -sNodeRemove :: (Ord t) => SPPF t -> (Symbol t, Int, Int) -> SPPF t-sNodeRemove (sm,iMap,pMap,eMap) (s,l,r) = - (IM.adjust inner l sm, iMap,pMap,eMap)- where inner = IM.adjust ((s `S.delete`)) r+-- | Class whose members are super-types of 'Token'.+class SubsumesToken a where+ upcast :: Token -> a+ downcast :: a -> Maybe Token -iNodeLookup :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> Bool -iNodeLookup (_,iMap,_,_) (s,l,r) = maybe False inner $ IM.lookup l iMap- where inner = maybe False (S.member s) . IM.lookup r+instance SubsumesToken Token where+ upcast = id+ downcast = Just . id -iNodeInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t-iNodeInsert f t (sMap,iMap,pMap,eMap) = - let iMap' = case f of- INode (s, l, r) -> newt (add s l r iMap)- _ -> newt iMap- in (sMap,iMap',pMap,eMap)- where newt iMap = case t of - (INode (s, l, r)) -> add s l r iMap- _ -> iMap- add s l r iMap = IM.alter addInnerL l iMap- where addInnerL mm = case mm of - Nothing -> Just singleRS- Just m -> Just $ IM.insertWith (S.union) r singleS m- singleRS = IM.fromList [(r, singleS)]- singleS = S.singleton s- -iNodeRemove :: (Ord t) => SPPF t -> (Slot t, Int, Int) -> SPPF t-iNodeRemove (sMap,iMap,pMap,eMap) (s,l,r) = - (sMap,IM.adjust inner l iMap,pMap,eMap)- where inner = IM.adjust ((s `S.delete`)) r+deriving instance Ord Token+deriving instance Eq Token -eMapInsert :: (Ord t) => SPPFNode t -> SPPFNode t -> SPPF t -> SPPF t-eMapInsert f t (sMap,iMap,pMap,eMap) = - (sMap,iMap,pMap,M.insertWith (S.union) f (S.singleton t) eMap)+instance Show Token where+ show (Char c) = "char('" ++ [c] ++ "')"+ show (Keyword s) = "keyword(\"" ++ s ++ "\")"+ show (EOS) = "<end-of-string>"+ show (Epsilon) = "<epsilon>"+ show (IntLit (Just i)) = "int(" ++ show i ++ ")"+ show (IntLit _) = "<int>"+ show (BoolLit (Just b)) = "bool(" ++ show b ++ ")"+ show (BoolLit _) = "<bool>"+ show (StringLit (Just s)) = "string(\"" ++ s ++ "\")"+ show (StringLit _) = "<string>"+ show (CharLit (Just c)) = "char-literal('" ++ [c] ++ "')"+ show (CharLit Nothing) = "<char>"+ show (AltIDLit (Just id)) = "altid(\"" ++ id ++ "\")"+ show (AltIDLit Nothing) = "<altid>"+ show (IDLit (Just id)) = "id(\"" ++ id ++ "\")"+ show (IDLit Nothing) = "<id>"+ show (Token nm (Just s)) = nm ++ "(\"" ++ s ++ "\")"+ show (Token nm _) = "<" ++ nm ++ ">"+ +instance Parseable Token where+ eos = EOS+ eps = Epsilon --- helpers for Ucal-inU (slot,l,i) u = maybe False inner $ IM.lookup l u- where inner = maybe False (S.member slot) . IM.lookup i+ unlex = unlexToken -toU (slot,l,i) u = IM.alter inner l u- where inner mm = case mm of- Nothing -> Just $ singleIS- Just m -> Just $ IM.insertWith S.union i singleS m- singleIS = IM.fromList [(i,singleS)]- singleS = S.singleton slot+ Token k _ `matches` Token k' _ = k' == k+ Char c `matches` Char c' = c' == c+ Keyword k `matches` Keyword k' = k' == k+ EOS `matches` EOS = True+ Epsilon `matches` Epsilon = True+ StringLit _ `matches` StringLit _ = True+ CharLit _ `matches` CharLit _ = True+ IntLit _ `matches` IntLit _ = True+ BoolLit _ `matches` BoolLit _ = True+ AltIDLit _ `matches` AltIDLit _ = True+ IDLit _ `matches` IDLit _ = True+ _ `matches` _ = False -showD dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]-showG dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]-showP 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 ]-showS sMap = unlines [ show (l,r) ++ " --> " ++ show (sset)- | (l,r2s) <- IM.assocs sMap, (r,sset) <- IM.assocs r2s]--- TODO change to Map-showSPPF :: Show t => SPPF t -> String -showSPPF (_,_,pMap,_) = showP pMap ---- smart constructors-nT x = Nt x-epsilon = []--type ProdMap t = M.Map Nt [Prod t]-type PrefixMap t = M.Map (Prod t,Int) ([t], Maybe Nt)-type SelectMap t = M.Map (Nt, [Symbol t]) (S.Set t)-type FirstMap t = M.Map Nt (S.Set t)-type FollowMap t = M.Map Nt (S.Set t)--fixedMaps :: (Eq t, Ord t, Parseable t) => Nt -> [Prod t] -> - (ProdMap t, PrefixMap t, FirstMap t, FollowMap t, SelectMap t) -fixedMaps s prs = let f = (prodMap, prefixMap, firstMap, followMap, selectMap)- in f `seq` f- where- prodMap = M.fromListWith (++) [ (x,[pr]) | pr@(Prod x _) <- prs ]-- prefixMap = M.fromList - [ ((pr,j), (tokens,msymb)) | pr@(Prod x alpha) <- prs- , (j,tokens,msymb) <- prefix x alpha ]- where- prefix x alpha = map rangePrefix ranges- where js = (map ((+) 1) (findIndices isNt alpha))- ranges = zip (0:js) (js ++ [length alpha])- rangePrefix (a,z) | a >= z = (a,[],Nothing)- rangePrefix (a,z) = - let init = map ((\(Term t) -> t) . (alpha !!)) [a .. (z-2)]- last = alpha !! (z-1)- in case last of - Nt nt -> (a,init, Just nt)- Term t -> (a,init ++ [t], Nothing)-- firstMap = M.fromList [ (x, first_x [] x) | x <- M.keys prodMap ]-- first_x ys x = S.unions [ first_alpha (x:ys) rhs | Prod _ rhs <- prodMap M.! x ]- - selectMap = M.fromList [ ((x,alpha), select alpha x) | Prod x rhs <- prs- , alpha <- split rhs ]- where- split rhs = foldr op [] js- where op j acc = drop j rhs : acc- js = 0 : findIndices isNt rhs-- -- TODO store intermediate results- select alpha x = res - where firsts = first_alpha [] alpha- res | eps `S.member` firsts = S.delete eps firsts `S.union` (followMap M.! x)- | otherwise = firsts-- -- list of symbols to get firsts from + non-terminal to ignore- -- TODO store in map- first_alpha ys [] = S.singleton eps - first_alpha ys (x:xs) = - case x of- Term tau -> if tau == eps then first_alpha ys xs- else S.singleton tau- Nt x -> - let fs | x `elem` ys = S.empty - | otherwise = first_x (x:ys) x- in if x `S.member` nullableSet- then S.delete eps fs `S.union` first_alpha (x:ys) xs- else fs-- followMap = M.fromList [ (x, follow [] x) | x <- M.keys prodMap ] - - follow ys x = S.unions (map fw (maybe [] id $ M.lookup x localMap))- `S.union` (if x == s then S.singleton eos else S.empty)- where fw (y,ss) = - let ts = S.delete eps (first_alpha [] ss)- fs = follow (x:ys) y - in if nullable_alpha [] ss && not (x `elem` (y:ys))- then ts `S.union` fs - else ts-- localMap = M.fromListWith (++)- [ (x,[(y,tail)]) | x <- M.keys prodMap, (Prod y rhs) <- prs- , tail <- tails x rhs ]- where- tails x symbs = [ drop (index + 1) symbs | index <- indices ]- where indices = elemIndices (Nt x) symbs- - nullableSet :: S.Set Nt- nullableSet = S.fromList $ [ x | x <- M.keys prodMap, nullable_x [] x ]-- -- a nonterminal is nullable if any of its alternatives is empty - nullable_x :: [Nt] -> Nt -> Bool- nullable_x ys x = or [ nullable_alpha (x:ys) rhs - | (Prod _ rhs) <- prodMap M.! x ] +-- | Pretty-prints a list of 'Token's as a concatenation of their lexemes.+unlexTokens :: [Token] -> String+unlexTokens = Prelude.concatMap unlexToken - -- TODO store in map- nullable_alpha :: [Nt] -> [Symbol t] -> Bool- nullable_alpha ys [] = True- nullable_alpha ys (s:ss) = - case s of- Nt nt -> if nt `elem` ys - then False --nullable only if some other alternative is nullable- else nullable_x ys nt && nullable_alpha (nt:ys) ss- otherwise -> False+unlexToken :: Token -> String+unlexToken t = case t of + Char c -> [c]+ Keyword s -> s+ IntLit (Just i) -> show i+ BoolLit (Just b) -> show b+ StringLit (Just s) -> s+ CharLit (Just c) -> [c]+ AltIDLit (Just s) -> s+ IDLit (Just s) -> s+ Token _ (Just s) -> s+ _ -> "" -- some helpers+ isNt (Nt _) = True isNt _ = False isTerm (Term _) = True isTerm _ = False -isChar (Char _) = True-isChar _ = False --deriving instance (Ord t) => Ord (Slot t)-deriving instance (Eq t) => Eq (Slot t)-deriving instance (Show t) => Show (Prod t)-deriving instance (Ord t) => Ord (Prod t)-deriving instance (Eq t) => Eq (Prod t)-deriving instance (Eq t) => Eq (Symbol t)-deriving instance (Ord t) => Ord (Symbol t)-{--instance Show Symbol where- show (Nt nt) = "Nt " ++ show nt- show (Term t) = "Term " ++ show t- show (Error t1 t2) = "Error " ++ show t1 ++ " " ++ show t2--instance Eq Symbol where- (Nt nt) == (Nt nt') = nt == nt'- (Term t) == (Term t') = t == t'- (Error t1 t2) == (Error t1' t2') = (t1,t2) == (t1',t2')--instance Ord Symbol where- (Nt nt) `compare` (Nt nt') = nt `compare` nt- (Nt _) `compare` _ = LT- _ `compare` (Nt _) = GT- (Term t) `compare` (Term t') = t `compare` t'- (Term _) `compare` _ = LT- _ `compare` (Term _) = GT- (Error t1 t2) `compare` (Error t1' t2') = (t1,t2) `compare` (t1',t2')--}- instance (Show t) => Show (Slot t) where show (Slot x alpha beta) = show x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta where showRhs [] = ""@@ -318,4 +172,12 @@ instance (Show t) => Show (Symbol t) where show (Nt s) = show s show (Term t) = show t++deriving instance (Ord t) => Ord (Slot t)+deriving instance (Eq t) => Eq (Slot t)+deriving instance (Show t) => Show (Prod t)+deriving instance (Ord t) => Ord (Prod t)+deriving instance (Eq t) => Eq (Prod t)+deriving instance (Eq t) => Eq (Symbol t)+deriving instance (Ord t) => Ord (Symbol t)