diff --git a/gll.cabal b/gll.cabal --- a/gll.cabal +++ b/gll.cabal @@ -3,7 +3,7 @@ -- The name of the package. name: gll -version: 0.3.0.0 +version: 0.3.0.1 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE @@ -12,7 +12,7 @@ category: Compilers build-type: Simple cabal-version: >=1.8 -tested-with: GHC == 7.6.3 +tested-with: GHC == 7.4.1, GHC == 7.8.3, GHC == 7.10.1 copyright: Copyright (C) 2015 L. Thomas van Binsbergen stability: experimental description: @@ -47,6 +47,7 @@ , GLL.Combinators.Test.Interface , GLL.Combinators , GLL.Parser + , GLL.Parseable.Char other-modules : GLL.Types.Abstract , GLL.Combinators.Memoisation , GLL.Combinators.Options diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs --- a/src/GLL/Combinators/Interface.hs +++ b/src/GLL/Combinators/Interface.hs @@ -201,11 +201,17 @@ Token(..), Parseable(..), -- * Running a parser parse, - -- ** Running a parser with disambiguation options + -- ** Running a parser with options parseWithOptions, -- *** Possible options - Options, Option, leftBiased, maximumPivot, maximumPivotAtNt, + CombinatorOptions, CombinatorOption, leftBiased, maximumPivot, maximumPivotAtNt, 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(..), -- * Derived combinators mkNt, -- *** Ignoring semantic results @@ -225,7 +231,7 @@ import GLL.Combinators.Visit.Grammar import GLL.Combinators.Memoisation import GLL.Types.Abstract -import GLL.Parser hiding (parse, parseWithOptions) +import GLL.Parser hiding (parse, parseWithOptions, Options, Option, runOptions) import qualified GLL.Parser as GLL import Control.Arrow @@ -255,9 +261,9 @@ -- | A list of alternatives represents the right-hand side of a rule. type AltExprs = OO [] AltExpr -parse' :: (Show t, Parseable t, IsSymbExpr s) => +parse' :: (Show t, Parseable t, IsSymbExpr s) => ParseOptions -> PCOptions -> s t a -> [t] -> (Grammar t, ParseResult t, Either String [a]) -parse' opts p' input = +parse' popts opts p' input = let SymbExpr (Nt start,vpa2,vpa3) = mkRule ("__Start" <:=> OO [id <$$> p']) snode = (start, 0, m) m = length input @@ -265,21 +271,16 @@ as = vpa3 opts IM.empty sppf arr 0 m grammar = (start, [ p | (_, alts) <- M.assocs rules, p <- alts ]) max_err = max_errors opts - parse_res = GLL.parseWithOptions [strictBinarisation, packedNodesOnly, GLL.maximumErrors max_err] grammar input + 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 else Left (error_message parse_res) ) --- | The grammar of a given parser +-- | The grammar of a given parser. grammar :: (Show t, Parseable t, IsSymbExpr s) => s t a -> Grammar t -grammar p = (\(f,_,_) -> f) (parse' defaultOptions p []) - --- | Get the SPPF produced by parsing the given input with the given parser -sppf :: (Show t, Parseable t, IsSymbExpr s) => - s t a -> [t] -> ParseResult t -sppf p str = (\(_,s,_) -> s) $ parse' defaultOptions p str +grammar p = (\(f,_,_) -> f) (parse' defaultPOpts defaultOptions p []) -- | -- Runs a parser given a string of 'Parseable's and returns a list of @@ -288,21 +289,35 @@ parse = parseWithOptions [] -- | --- Run the parser with some 'Options'. +-- Run the parser with some 'CombinatorOptions'. parseWithOptions :: (Show t, Parseable t, IsSymbExpr s) => - Options -> s t a -> [t] -> [a] + CombinatorOptions -> s t a -> [t] -> [a] parseWithOptions opts p ts = case parseWithOptionsAndError opts p ts of Left str | throw_errors opts' -> error str | otherwise -> [] Right as -> as where opts' = runOptions opts + -- | --- Run the parser with some 'Options' and return either an error or the results. +-- 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) => - Options -> s t a -> [t] -> Either String [a] -parseWithOptionsAndError opts p = (\(_,_,t) -> t) . parse' (runOptions opts) p + CombinatorOptions -> s t a -> [t] -> Either String [a] +parseWithOptionsAndError 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 <:=> -- | diff --git a/src/GLL/Combinators/Options.hs b/src/GLL/Combinators/Options.hs --- a/src/GLL/Combinators/Options.hs +++ b/src/GLL/Combinators/Options.hs @@ -2,51 +2,51 @@ import Data.Function (on) --- | Options datatype +-- | CombinatorOptions datatype -- * left_biased_choice: see function leftBiased -- * pivot_select: provide a filtering function on `pivots' data PCOptions = PCOptions { left_biased_choice :: Bool , pivot_select :: Maybe (Int -> Int -> Ordering) , pivot_select_nt :: Bool - , max_errors :: Int , throw_errors :: Bool , do_memo :: Bool + , max_errors :: Int } --- | A list of 'Option's for evaluating combinator expressions. -type Options = [Option] +-- | A list of 'CombinatorOption's for evaluating combinator expressions. +type CombinatorOptions = [CombinatorOption] -- | A single option. -type Option = PCOptions -> PCOptions +type CombinatorOption = PCOptions -> PCOptions -runOptions :: [Option] -> PCOptions +runOptions :: CombinatorOptions -> PCOptions runOptions = foldr ($) defaultOptions -- | The default options: no disambiguation. defaultOptions :: PCOptions -defaultOptions = PCOptions False Nothing False 3 False False +defaultOptions = PCOptions False Nothing False False False 3 -- | Enables a 'longest-match' at production level. -maximumPivot :: Option +maximumPivot :: CombinatorOption maximumPivot opts = opts {pivot_select = Just compare} -- | Enables a 'shortest-match' at production level. -minimumPivot :: Option +minimumPivot :: CombinatorOption minimumPivot opts = opts {pivot_select = Just (flip compare)} -- | Enables 'longest-match' at non-terminal level. -maximumPivotAtNt :: Option +maximumPivotAtNt :: CombinatorOption maximumPivotAtNt opts = opts {pivot_select_nt = True, pivot_select = Just compare} -- | -- Set the maximum number of errors shown in case of an unsuccessful parse. -maximumErrors :: Int -> Option -maximumErrors n flags = flags {max_errors = n} +maximumErrors :: Int -> CombinatorOption +maximumErrors n opts = opts { max_errors = n } -- | -- If there are no parse results, the default behaviour is to return an empty list. -- If this option is used, a runtime error will be reported, with debugging information. -throwErrors :: Option +throwErrors :: CombinatorOption throwErrors opts = opts{throw_errors = True} @@ -54,12 +54,12 @@ -- Turns all occurrences of '<||>' into a 'left biased' variant: -- only return results of the second alternate if the first alternate -- does not have any results. -leftBiased :: Option +leftBiased :: CombinatorOption leftBiased opts = opts { left_biased_choice = True } -- | --- Whether to use unsafe memoisation to speed up the enumeration of parse results -useMemoisation :: Option +-- Whether to use unsafe memoisation to speed up the enumeration of parse results. +useMemoisation :: CombinatorOption useMemoisation opts = opts { do_memo = True } -- | Filter a list such that the only remaining elements are equal to diff --git a/src/GLL/Parseable/Char.hs b/src/GLL/Parseable/Char.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Parseable/Char.hs @@ -0,0 +1,11 @@ + +-- | Exports an instance for 'Parseable' 'Char' +-- that sssumes '$' and '#' never appear in the inpur string. +module GLL.Parseable.Char () where + +import GLL.Types.Abstract + +-- | Assumes '$' and '#' never appear in the inpur string. +instance Parseable Char where + eos = '$' + eps = '#' diff --git a/src/GLL/Parser.hs b/src/GLL/Parser.hs --- a/src/GLL/Parser.hs +++ b/src/GLL/Parser.hs @@ -165,14 +165,16 @@ parse, -- ** Run the GLL parser with options parseWithOptions, - -- *** Options + -- *** ParseOptions + ParseOptions, ParseOption, strictBinarisation, fullSPPF, allNodes, packedNodesOnly, maximumErrors, -- ** Result - ParseResult(..), SPPF(..), SPPFNode(..), SymbMap, ImdMap, PackMap, EdgeMap, + ParseResult(..), SPPF(..), SPPFNode(..), SymbMap, ImdMap, PackMap, EdgeMap, showSPPF, ) where import Data.Foldable hiding (forM_, toList, sum) -import Prelude hiding (lookup, foldr, fmap, foldl, elem) +import Prelude hiding (lookup, foldr, fmap, foldl, elem, any) +import Control.Applicative import Control.Monad import qualified Data.IntMap as IM import qualified Data.Map as M @@ -303,31 +305,45 @@ (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 } -defaultOptions = Flags False False False True 3 -runOptions = foldr ($) defaultOptions -type Option = Flags -> Flags -type Options = [Option] +-- | 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 :: Option +fullSPPF :: ParseOption fullSPPF flags = flags{symbol_nodes = True, intermediate_nodes = True, edges = True} -- | -- Create all nodes, but no edges between nodes. -allNodes :: Option +allNodes :: ParseOption allNodes flags = flags{symbol_nodes = True, intermediate_nodes = True} -- | -- Create packed-nodes only. -packedNodesOnly :: Option +packedNodesOnly :: ParseOption packedNodesOnly flags = flags{symbol_nodes = False, intermediate_nodes = False, edges = False} -- | @@ -335,12 +351,12 @@ -- 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 :: Option +strictBinarisation :: ParseOption strictBinarisation flags = flags{flexible_binarisation = False} -- | -- Set the maximum number of errors shown in case of an unsuccessful parse. -maximumErrors :: Int -> Option +maximumErrors :: Int -> ParseOption maximumErrors n flags = flags {max_errors = n} -- | @@ -357,7 +373,7 @@ -- -- * only packed nodes are created -- * the resulting 'SPPF' is not strictly binarised -parseWithOptions :: Parseable t => [Option] -> Grammar t -> [t] -> ParseResult t +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 @@ -480,7 +496,8 @@ data ParseResult t = ParseResult{ sppf_result :: SPPF t , res_success :: Bool , nr_descriptors :: Int - , nr_symbol_nodes :: Int + , nr_nterm_nodes :: Int + , nr_term_nodes :: Int , nr_intermediate_nodes :: Int , nr_packed_nodes :: Int , nr_sppf_edges :: Int @@ -496,7 +513,7 @@ usize = sum [ S.size s | (l, r2s) <- IM.assocs u , (r,s) <- IM.assocs r2s ] s_nodes = sum [ S.size s | (l, r2s) <- IM.assocs sMap - , (r, s) <- IM.assocs r2s ] + m + , (r, s) <- IM.assocs r2s ] i_nodes = sum [ S.size s | (l, r2s) <- IM.assocs iMap , (r, s) <- IM.assocs r2s ] p_nodes = sum [ IS.size ks | (l, r2j) <- IM.assocs pMap @@ -508,7 +525,7 @@ gss_edges = 1 + sum [ length s | (l,x2s) <- IM.assocs gss , (x,s) <- M.assocs x2s ] sppf@(sMap, iMap, pMap, eMap) = mut_sppf mutable - in ParseResult sppf (mut_success mutable) usize s_nodes i_nodes p_nodes sppf_edges gss_nodes gss_edges (renderErrors inp flags (mut_mismatches mutable)) + in ParseResult sppf (mut_success mutable) usize s_nodes m i_nodes p_nodes sppf_edges gss_nodes gss_edges (renderErrors inp flags (mut_mismatches mutable)) renderErrors :: Show t => Input t -> Flags -> MisMatches t -> String renderErrors inp flags mm = render doc @@ -525,14 +542,17 @@ ppExp = text . show instance Show (ParseResult t) where - show res | res_success res = unlines $ - [ "Descriptors: " ++ show (nr_descriptors res) - , "Symbol nodes: " ++ show (nr_symbol_nodes res) + show res | res_success res = result_string + | otherwise = result_string ++ "\n" ++ error_message res + where result_string = unlines $ + [ "Success " ++ show (res_success res) + , "Descriptors: " ++ show (nr_descriptors res) + , "Nonterminal nodes: " ++ show (nr_nterm_nodes res) + , "Terminal nodes: " ++ show (nr_term_nodes res) , "Intermediate nodes: " ++ show (nr_intermediate_nodes res) , "Packed nodes: " ++ show (nr_packed_nodes res) , "SPPF edges: " ++ show (nr_sppf_edges res) , "GSS nodes: " ++ show (nr_gss_nodes res) , "GSS edges: " ++ show (nr_gss_edges res) ] - | otherwise = error_message res diff --git a/src/GLL/Types/Grammar.hs b/src/GLL/Types/Grammar.hs --- a/src/GLL/Types/Grammar.hs +++ b/src/GLL/Types/Grammar.hs @@ -169,16 +169,8 @@ 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) => ([(SNode t,PNode t)],[(PNode t,SNode t)]) -> String -showSPPF (se,pe) = "\n"++ (unlines $ map ppPn $ pe) ++ "\n" ++ - (unlines $ map ppSn $ se) - where ppPn ((Prod x alpha, rs), sn) = ppRhs (x,alpha,rs) ++ " --> " ++ show sn - ppSn (sn, (Prod x alpha, rs)) = show sn ++ " --> " ++ ppRhs (x,alpha,rs) - ppRhs (x, alpha, rs) = "(" ++ x ++ " ::= "++ (foldr ((++) . ppS) "" alpha) ++ - foldr (\i -> (("," ++ show i) ++)) "" rs ++ ")" - ppS (Nt s) = s - ppS (Term t) = show t - +showSPPF :: Show t => SPPF t -> String +showSPPF (_,_,pMap,_) = showP pMap -- smart constructors nT x = Nt x