gll 0.3.0.1 → 0.3.0.6
raw patch · 11 files changed
+325/−77 lines, 11 filesdep +regex-applicativedep +textdep ~base
Dependencies added: regex-applicative, text
Dependency ranges changed: base
Files
- changelog.txt +22/−0
- gll.cabal +6/−1
- src/GLL/Combinators/Interface.hs +159/−59
- src/GLL/Combinators/Lexer.hs +78/−0
- src/GLL/Combinators/Options.hs +4/−0
- src/GLL/Combinators/Test/Interface.hs +2/−3
- src/GLL/Combinators/Visit/Sem.hs +2/−2
- src/GLL/Parseable/Char.hs +2/−1
- src/GLL/Parser.hs +30/−6
- src/GLL/Types/Abstract.hs +17/−2
- src/GLL/Types/Grammar.hs +3/−3
+ changelog.txt view
@@ -0,0 +1,22 @@+0.3.0.1 -> 0.3.0.2+ + smart constructors for creating Grammars. To be used instead of constructors.+0.3.0.2 -> 0.3.0.3+ + SubsumesToken class for making Token a subtype of a custom Parseable type.+ The terminal parsers id_lit, int_lit, etc. can be used directly.+ + Additional constructor in 'Token' for alternative identifiers.+ - Method 'matches' of class 'Parseable' no longer has a default definition+ (default was (==)).+0.3.0.3 -> 0.3.0.4+ - Removed global disambiguation options (leftBiased, minimum/maximumPivot)+ + introduced lassoc, rassoc and assoc for associativity based + local disambiguation+ + renamed some to many1 and let many and many1 implement shortest-match,+ hence, if there is ambiguity the list with the maximum size is chosen.+ + introduced some and some1 that are the same as many/many1 except+ that they implement longest-match (resulting in minimum sized list)+ + introduced multiple and multiple1 that are as above but implementing+ no disambiguation (possibly useful for debuggin)+ + introduced manySepBy(1), someSepBy(1) and multipleSepBy(1)+0.3.0.4 -> 0.3.0.6+ + added missing string literal token to predefined lexer+ + added user-defined tokens to predefined lexer (given as a list)
gll.cabal view
@@ -3,7 +3,7 @@ -- The name of the package. name: gll-version: 0.3.0.1+version: 0.3.0.6 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE@@ -36,6 +36,8 @@ 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 && <= 4.8.0.0@@ -43,6 +45,8 @@ , array , TypeCompose , pretty+ , text+ , regex-applicative >= 0.3 exposed-modules : GLL.Combinators.Interface , GLL.Combinators.Test.Interface , GLL.Combinators@@ -51,6 +55,7 @@ other-modules : GLL.Types.Abstract , GLL.Combinators.Memoisation , GLL.Combinators.Options+ , GLL.Combinators.Lexer , GLL.Types.Grammar , GLL.Combinators.Visit.Grammar , GLL.Combinators.Visit.Sem
src/GLL/Combinators/Interface.hs view
@@ -182,7 +182,7 @@ -- * Elementary parsers term_parser, satisfy, -- ** Elementary parsers using the 'Token' datatype - keychar, keyword, int_lit, bool_lit, string_lit, id_lit, token,+ keychar, keyword, int_lit, bool_lit, string_lit, alt_id_lit, id_lit, token, -- ** Elementary character-level parsers char, -- * Elementary combinators@@ -198,29 +198,35 @@ -- ** Grammar (combinator expression) types BNF, SymbExpr, AltExpr, AltExprs, -- ** Parseable token types - Token(..), Parseable(..), + Token(..), Parseable(..), SubsumesToken(..), -- * Running a parser - parse,+ parse, -- ** Running a parser with options parseWithOptions, -- *** Possible options- CombinatorOptions, CombinatorOption, leftBiased, maximumPivot, maximumPivotAtNt,+ CombinatorOptions, CombinatorOption, GLL.Combinators.Options.maximumErrors, throwErrors, -- **** Parser options fullSPPF, allNodes, packedNodesOnly, strictBinarisation, -- *** Running a parser with options and explicit failure parseWithOptionsAndError, -- ** Runing a parser to obtain 'ParseResult'.- parseResult, parseResultWithOptions,ParseResult(..), + parseResult, parseResultWithOptions,ParseResult(..),+ -- ** Builtin lexers.+ default_lexer, + -- *** Lexer settings+ lexer, LexerSettings(..), emptyLanguage, -- * Derived combinators mkNt, -- *** Ignoring semantic results (<$$), (**>), (<**),- -- *** Post-parse disambiguation- (<::=), -- *** EBNF patterns- optional, many, some,- -- * Lifting+ optional, multiple, multiple1, multipleSepBy, multipleSepBy1,+ -- *** Disambiguation + (<::=),+ lassoc, rassoc, assoc,many, many1, some, some1, + manySepBy, manySepBy1, someSepBy, someSepBy1, + -- * Lifting HasAlts(..), IsSymbExpr(..), IsAltExpr(..), -- * Memoisation memo, newMemoTable, memClear, MemoTable, MemoRef, useMemoisation,@@ -230,16 +236,18 @@ import GLL.Combinators.Visit.Sem import GLL.Combinators.Visit.Grammar import GLL.Combinators.Memoisation+import GLL.Combinators.Lexer import GLL.Types.Abstract import GLL.Parser hiding (parse, parseWithOptions, Options, Option, runOptions) import qualified GLL.Parser as GLL import Control.Arrow import Control.Compose (OO(..),unOO)-import Data.List (intersperse)+import Data.List (intercalate) import qualified Data.Array as A import qualified Data.IntMap as IM import qualified Data.Map as M+import Data.Text (pack) import Data.IORef import System.IO.Unsafe @@ -274,8 +282,9 @@ parse_res = GLL.parseWithOptions (popts++[GLL.maximumErrors max_err]) grammar input sppf = sppf_result parse_res arr = A.array (0,m) (zip [0..] input)- in (grammar, parse_res, if res_success parse_res - then Right $ unsafePerformIO as+ res_list = unsafePerformIO as+ in (grammar, parse_res, if res_success parse_res && not (null res_list)+ then Right $ res_list else Left (error_message parse_res) ) -- | The grammar of a given parser.@@ -323,7 +332,7 @@ -- | -- 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) => Nt -> b t a -> SymbExpr t a +(<:=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a x <:=> altPs = mkNtRule False False x altPs infixl 2 <::=> @@ -335,16 +344,17 @@ -- 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) => Nt -> b t a -> SymbExpr t a +(<::=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a x <::=> altPs = mkNtRule True False x altPs -mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> Nt -> b t a -> SymbExpr t a-mkNtRule use_ctx left_biased x altPs' =+mkNtRule :: (Show t, Ord t, HasAlts b) => Bool -> Bool -> String -> b t a -> SymbExpr t a+mkNtRule use_ctx left_biased x' altPs' = let vas1 = map (\(AltExpr (f,_,_)) -> f) altPs vas2 = map (\(AltExpr (_,s,_)) -> s) altPs vas3 = map (\(AltExpr (_,_,t)) -> t) altPs alts = map (Prod x) vas1 altPs = altsOf altPs'+ x = pack x' in SymbExpr (Nt x, grammar_nterm x alts vas2, sem_nterm use_ctx left_biased x alts vas3) infixl 4 <$$>@@ -378,6 +388,24 @@ r = altsOf r' in OO (l : r) +-- |+-- Apply this combinator to an alternative to indicate that the alternative+-- is for a left-associative operator. Used for top-down disambiguation.+lassoc :: AltExpr t a -> AltExpr t a+lassoc (AltExpr (v1,v2,v3)) = AltExpr (v1,v2,\opts -> v3 (maximumPivot opts))++-- |+-- Apply this combinator to an alternative to indicate that the alternative+-- is for a right-associative operator. Used for top-down disambiguation.+rassoc :: AltExpr t a -> AltExpr t a+rassoc (AltExpr (v1,v2,v3)) = AltExpr (v1,v2,\opts -> v3 (minimumPivot opts))++-- |+-- Apply this combinator to an alternative to indicate that the alternative+-- is for an associative operator. Used for top-down disambiguation.+assoc :: AltExpr t a -> AltExpr t a+assoc = lassoc+ -- | Create a symbol-parse for a terminal given: -- -- * The 'Parseable' token represented by the terminal.@@ -414,51 +442,59 @@ parens p = within (char '(') p (char ')') -} --- | Parse a single character, using the 'Token' datatype.-keychar :: Char -> SymbExpr Token Char-keychar c = term_parser (Char c) (const c) -- helper for Char tokens+-- | Parse a single character, using a 'SubsumesToken' type.+keychar :: SubsumesToken t => Char -> SymbExpr t Char+keychar c = term_parser (upcast (Char c)) (const c) -- helper for Char tokens --- | Parse a single character, using the 'Token' datatype.-keyword :: String -> SymbExpr Token String-keyword k = term_parser (Keyword k) (const k) -- helper for Char tokens+-- | Parse a single character, using a 'SubsumesToken' type.+keyword :: SubsumesToken t => String -> SymbExpr t String+keyword k = term_parser (upcast (Keyword k)) (const k) -- helper for Char tokens --- | Parse a single integer, using the 'Token' datatype.+-- | Parse a single integer, using a 'SubsumesToken' type. -- Returns the lexeme interpreted as an integer.-int_lit :: SymbExpr Token Int-int_lit = term_parser (IntLit Nothing) unwrap- where unwrap (IntLit (Just i)) = i- unwrap _ = error "int_lit: the token must store lexeme"+int_lit :: 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 Boolean, using the 'Token' datatype.+-- | Parse a single Boolean, using a 'SubsumesToken' type. -- Returns the lexeme interpreter as a Boolean.-bool_lit :: SymbExpr Token Bool-bool_lit = term_parser (BoolLit Nothing) unwrap- where unwrap (BoolLit (Just b)) = b- unwrap _ = error "bool_lit: the token must store lexeme"+bool_lit :: 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 String literal, using the 'Token' datatype.+-- | Parse a single String literal, using a 'SubsumesToken' type. -- Returns the lexeme interpreted as a String literal.-string_lit :: SymbExpr Token String-string_lit = term_parser (StringLit Nothing) unwrap- where unwrap (StringLit (Just i)) = i- unwrap _ = error "string_lit: the token must store lexeme"+string_lit :: 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 the 'Token' datatype.--- Returns the lexeme as a String-id_lit :: SymbExpr Token String-id_lit = term_parser (IDLit Nothing) unwrap- where unwrap (IDLit (Just i)) = i- unwrap _ = error "id_lit: the token must store lexeme"+-- | Parse a single identifier, using a 'SubsumesToken' type.+-- Returns the lexeme as a String.+id_lit :: 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 arbitrary token, using the 'Token' datatype.+-- | Parse a single alternative identifier, using a 'SubsumesToken' type.+-- Returns the lexeme as a String.+alt_id_lit :: 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 :: String -> SymbExpr Token String-token name = term_parser (Token name Nothing) unwrap- where unwrap (Token name' (Just i)) | name == name' = i- unwrap _ = error "tokenT: the token must store the lexeme"+token :: 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 ([], M.insert x [Prod x []],\_ _ _ _ _ l r -> +epsilon = AltExpr ([], M.insert (pack x) [Prod (pack x) []],\_ _ _ _ _ l r -> if l == r then return [(l,())] else return [] ) where x = "__eps" @@ -498,7 +534,7 @@ -- 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 -> Nt+mkNt :: (Show t, Ord t, IsSymbExpr s) => s t a -> String -> String mkNt p str = let SymbExpr (myx,_,_) = mkRule p in "_(" ++ show myx ++ ")" ++ str @@ -528,20 +564,84 @@ infixl 4 <** -- | --- Left-biased version of '<::='+-- Version of '<::=' that prioritises productions from left-to-right (or top-to-bottom). x <::= altPs = mkNtRule True True x altPs infixl 2 <::= --- | Try to apply a parser `many' (0 or more) times. The results are returned in a list.+-- | 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. many :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]-many p = let fresh = mkNt p "*" --TODO using <:=> or <::=> ? - in fresh <::=> (:) <$$> p <**> many p <||> satisfy []+many = multiple_ rassoc +-- | Try to apply a parser multiple times (1 or more). The results are returned in a list.+-- In the case of ambiguity the largest list is returned.+many1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+many1 = multiple1_ rassoc --- | Try to apply a parser `some' (1 or more) times. The results are returned in a list.+-- | 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. some :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]-some p = let fresh = mkNt p "+"- in fresh <::=> (:) <$$> p <**> many p +some = multiple_ lassoc +-- | 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.+some1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+some1 = multiple1_ lassoc++-- | Try to apply a parser multiple times (0 or more). The results are returned in a list.+-- In the case of ambiguity the largest list is returned.+multiple :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+multiple = multiple_ id++-- | Try to apply a parser multiple times (1 or more). The results are returned in a list.+-- In the case of ambiguity the largest list is returned.+multiple1 :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t [a]+multiple1 = multiple1_ id++-- | Internal+multiple_ :: (Show t, Ord t, IsSymbExpr s) => (AltExpr t [a] -> AltExpr t [a]) ->+ s t a -> SymbExpr t [a]+multiple_ disa p = let fresh = mkNt p "*" + in fresh <::=> disa ((:) <$$> p <**> multiple p) <||> satisfy []++-- | Internal+multiple1_ :: (Show t, Ord t, IsSymbExpr s) => (AltExpr t [a] -> AltExpr t [a]) ->+ s t a -> SymbExpr t [a]+multiple1_ disa p = let fresh = mkNt p "+"+ in fresh <::=> disa ((:) <$$> p <**> multiple p)++-- | 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)+ -- | Try to apply a parser once, but proceed if unsuccessful -- (yielding 'Nothing' as a result in that case). optional :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a)@@ -564,8 +664,8 @@ instance IsSymbExpr AltExprs where toSymb a = mkName <:=> a - where mkName = "_(" ++ concat (intersperse "|" (map op (unOO a))) ++ ")_"- where op (AltExpr (rhs,_,_)) = concat (intersperse "*" (map show rhs))+ where mkName = "_toSb(" ++ intercalate ")|(" (map op (unOO a)) ++ ")_"+ where op (AltExpr (rhs,_,_)) = "(" ++ intercalate ")*(" (map show rhs) ++ ")" -- | -- Class for lifting to 'AltExprs'. class HasAlts a where
+ src/GLL/Combinators/Lexer.hs view
@@ -0,0 +1,78 @@++module GLL.Combinators.Lexer (+ default_lexer, lexer, LexerSettings(..), emptyLanguage,+ ) where++import GLL.Types.Abstract (Token(..), SubsumesToken(..))+import Data.Char (isSpace, isDigit, isAlpha, isUpper, isLower)+import Text.Regex.Applicative++-- | Settings for changing the behaviour of the builtin lexer 'lexer'.+-- Lexers are built using "Text.Regex.Applicative".+data LexerSettings = LexerSettings {+ -- | Which keychars to recognise? Default: none.+ keychars :: [Char]+ -- | Which keywords to recognise? Default: none.+ , keywords :: [String]+ -- | What is considered a whitespace character? Default: 'Data.Char.isSpace'.+ , whitespace :: Char -> Bool+ -- | How does a line comment start? Default: '"'//'"'.+ , lineComment :: 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.+ , altIdentifiers :: RE Char String+ -- | Arbitrary tokens /(a,b)/. /a/ is the token name, /b/ is a regular expression.+ , tokens :: [(String, RE Char String)]+ }++-- | The default 'LexerSettings'.+emptyLanguage :: LexerSettings+emptyLanguage = LexerSettings [] [] isSpace "//"+ ((:) <$> psym isLower <*> lowercase_id)+ ((:) <$> psym isUpper <*> lowercase_id)+ []+ where lowercase_id = many (psym (\c -> isAlpha c || c == '_' || isDigit c))++-- | A lexer using the default 'LexerSettings'.+default_lexer :: SubsumesToken t => String -> [t]+default_lexer = lexer emptyLanguage ++-- | 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))++lTokens :: SubsumesToken t => LexerSettings -> RE Char t +lTokens lexsets =+ lCharacters+ <|> lKeywords+ <|> charsToInt <$> optional (sym '-') <*> some (psym isDigit)+ <|> upcast . IDLit . Just <$> identifiers lexsets + <|> upcast . AltIDLit . Just <$> altIdentifiers lexsets+ <|> upcast . StringLit . Just <$> lStringLit+ <|> lMore+ where + charsToInt Nothing n = upcast (IntLit (Just (read n)))+ charsToInt (Just _) n = upcast (IntLit (Just (-(read n))))++ lChar c = upcast (Char c) <$ sym c+ lCharacters = foldr ((<|>) . lChar) empty (keychars lexsets) ++ lKeyword k = upcast (Keyword k) <$ string k+ lKeywords = foldr ((<|>) . lKeyword) empty (keywords lexsets)++ lMore = foldr ((<|>) . uncurry lToken) empty (tokens lexsets)+ lToken t re = upcast . Token t . Just <$> re++ lStringLit = toString <$ sym '\"' <*> many strChar <* sym '\"'+ where strChar = sym '\\' *> sym '\"'+ <|> psym ((/=) '\"')+ toString inner = read ("\"" ++ inner ++ "\"")
src/GLL/Combinators/Options.hs view
@@ -34,6 +34,10 @@ minimumPivot :: CombinatorOption minimumPivot opts = opts {pivot_select = Just (flip compare)} +-- | Discards a pivot select option (internal use only)+anyPivot :: CombinatorOption+anyPivot opts = opts {pivot_select = Nothing}+ -- | Enables 'longest-match' at non-terminal level. maximumPivotAtNt :: CombinatorOption maximumPivotAtNt opts = opts {pivot_select_nt = True, pivot_select = Just compare}
src/GLL/Combinators/Test/Interface.hs view
@@ -34,6 +34,7 @@ import Data.IORef import GLL.Combinators.Interface+import GLL.Parseable.Char () -- | Defines and executes some unit-tests main = do@@ -233,6 +234,4 @@ _EEE_3 = ["00111","01011","01101","01110","10011","10101","10110","11001","11010","111","11100"] -instance Parseable Char where- eos = '$'- eps = '#'+
src/GLL/Combinators/Visit/Sem.hs view
@@ -19,7 +19,8 @@ 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 + 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@@ -70,5 +71,4 @@ Just m -> Just $ IM.insertWith (S.union) r singleX m singleRX = IM.singleton r singleX singleX = S.singleton x-
src/GLL/Parseable/Char.hs view
@@ -1,6 +1,6 @@ -- | Exports an instance for 'Parseable' 'Char' --- that sssumes '$' and '#' never appear in the inpur string.+-- that assumes '$' and '#' never appear in the inpur string. module GLL.Parseable.Char () where import GLL.Types.Abstract@@ -9,3 +9,4 @@ instance Parseable Char where eos = '$' eps = '#'+ matches = (==)
src/GLL/Parser.hs view
@@ -115,14 +115,15 @@ @ This instance mandates that \'$\' and '#' are 'reserved tokens' -and not part of the input string.+and not part of the input string. This instance is available as an import: +"GLL.Parseable.Char". -"GLL.Parser" exports 'Prod' for constructing 'Grammar's.+"GLL.Parser" exports smart constructors for constructing 'Grammar's. @-grammar1 = (\"X\", [Prod \"X\" [Nt \"A\", Nt \"A\"]- ,Prod \"A\" [Term \'a\']- ,Prod \"A\" [Term \'a\', Term \'a\']+grammar1 = (start \"X\" , [prod \"X\" [nterm \"A\", nterm \"A\"]+ , prod \"A\" [term \'a\']+ , prod \"A\" [term \'a\', term \'a\'] ] ) fail1 = "a"@@ -158,7 +159,9 @@ -} module GLL.Parser ( -- * Grammar- Grammar(..), Prods(..), Prod(..), Symbols(..), Symbol(..), Slot(..),+ Grammar(..), Prods(..), Prod(..), Symbols(..), Symbol(..), Slot(..), + -- ** Smart constructors for creating 'Grammar's+ start, prod, nterm, term, -- ** Parseable tokens Parseable(..), -- * Run the GLL parser@@ -181,10 +184,31 @@ import qualified Data.Array as A import qualified Data.Set as S import qualified Data.IntSet as IS+import Data.Text (pack) import Text.PrettyPrint.HughesPJ as PP import GLL.Types.Abstract import GLL.Types.Grammar++-- | Create an 'Nt' (nonterminal) from a String.+string2nt :: String -> Nt+string2nt = pack++-- | A smart constructor for creating a start 'Nt' (nonterminal).+start :: String -> Nt+start = string2nt++-- | A smart constructor for creating a 'Prod' (production).+prod :: String -> Symbols t -> Prod t+prod x = Prod (string2nt x)++-- | A smart constructor for creating a nonterminal 'Symbol'.+nterm :: String -> Symbol t+nterm = Nt . string2nt++-- | A smart constructor for creating a terminal 'Symbol'.+term :: t -> Symbol t+term = Term -- | Representation of the input string type Input t = A.Array Int t
src/GLL/Types/Abstract.hs view
@@ -3,12 +3,14 @@ -- 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 = String+type Nt = Text -- Prod --------------------------------------------------------- -- | @@ -56,6 +58,8 @@ | BoolLit (Maybe Bool) | StringLit (Maybe String) | IDLit (Maybe String)+ -- | alternative identifiers, for example functions vs. constructors (as in Haskell).+ | AltIDLit (Maybe String) | Token String (Maybe String) -- Tokens ------------------------------------------------------ -- | @@ -78,8 +82,16 @@ -- Override this method if, for example, your input tokens store lexemes -- while the grammar tokens do not matches :: a -> a -> Bool- matches = (==) +-- | 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 @@ -94,6 +106,8 @@ show (BoolLit _) = "<bool>" show (StringLit (Just s)) = "string(\"" ++ s ++ "\")" show (StringLit _) = "<string>"+ 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 ++ "\")"@@ -111,6 +125,7 @@ StringLit _ `matches` StringLit _ = True IntLit _ `matches` IntLit _ = True BoolLit _ `matches` BoolLit _ = True+ AltIDLit _ `matches` AltIDLit _ = True IDLit _ `matches` IDLit _ = True _ `matches` _ = False
src/GLL/Types/Grammar.hs view
@@ -310,12 +310,12 @@ -} instance (Show t) => Show (Slot t) where- show (Slot x alpha beta) = x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta + show (Slot x alpha beta) = show x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta where showRhs [] = "" showRhs ((Term t):rhs) = show t ++ showRhs rhs- showRhs ((Nt x):rhs) = x ++ showRhs rhs+ showRhs ((Nt x):rhs) = show x ++ showRhs rhs instance (Show t) => Show (Symbol t) where- show (Nt s) = s+ show (Nt s) = show s show (Term t) = show t