Grempa (empty) → 0.1.0
raw patch · 30 files changed
+2190/−0 lines, 30 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, containers, monads-fd, template-haskell, th-lift
Files
- Data/Parser/Grempa/Aux/Aux.hs +90/−0
- Data/Parser/Grempa/Aux/MultiMap.hs +39/−0
- Data/Parser/Grempa/Dynamic.hs +7/−0
- Data/Parser/Grempa/Grammar.hs +124/−0
- Data/Parser/Grempa/Grammar/Token.hs +41/−0
- Data/Parser/Grempa/Grammar/Typed.hs +139/−0
- Data/Parser/Grempa/Grammar/Untyped.hs +155/−0
- Data/Parser/Grempa/Parser/Conflict.hs +45/−0
- Data/Parser/Grempa/Parser/Driver.hs +54/−0
- Data/Parser/Grempa/Parser/Dynamic.hs +100/−0
- Data/Parser/Grempa/Parser/Item.hs +108/−0
- Data/Parser/Grempa/Parser/LALR.hs +204/−0
- Data/Parser/Grempa/Parser/Result.hs +59/−0
- Data/Parser/Grempa/Parser/SLR.hs +110/−0
- Data/Parser/Grempa/Parser/Static.hs +148/−0
- Data/Parser/Grempa/Parser/Table.hs +62/−0
- Data/Parser/Grempa/Static.hs +7/−0
- Data/Parser/Grempa/Test.hs +86/−0
- Grempa.cabal +63/−0
- LICENSE +30/−0
- README +45/−0
- Setup.hs +2/−0
- examples/Ex1SimpleExpr.hs +58/−0
- examples/Ex1SimpleExprParser.hs +65/−0
- examples/Ex2Calculator.hs +76/−0
- examples/Ex2CalculatorParser.hs +44/−0
- examples/Ex3Fun.hs +93/−0
- examples/Ex3FunLex.hs +79/−0
- examples/Ex3FunParser.hs +31/−0
- examples/Ex4Test.hs +26/−0
+ Data/Parser/Grempa/Aux/Aux.hs view
@@ -0,0 +1,90 @@+-- | Auxillary functions for traversing recursive data structures such as+-- grammars, and for converting mappings to arrays.+module Data.Parser.Grempa.Aux.Aux where+import Control.Monad.State+import Data.Array+import Data.Map(Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Set(Set)+import qualified Data.Set as S++setFromJust :: Ord a => Set (Maybe a) -> Set a+setFromJust = S.map fromJust . S.delete Nothing++-- | Traverse a recursive data structure without doing the same thing more+-- than once and return a Set of results. Similar to a fold.+-- Takes a function returning (result, candidates), then the initial set+recTraverseG :: (Ord a, Ord b)+ => (Set a -> (Set b, Set a)) -- ^ Function returning (result,+ -- candidates)+ -> Set a -- ^ Input+ -> Set b+recTraverseG = recTraverseG' S.empty+ where+ recTraverseG' done f x = if S.null cand'+ then res+ else res `S.union` recTraverseG' done' f cand'+ where (res, cand) = f x+ cand' = cand S.\\ done'+ done' = done `S.union` x++-- | Traverse a recursive data structure where results and candidates is the+-- same thing.+recTraverse :: Ord a => (Set a -> Set a) -> Set a -> Set a+recTraverse f = recTraverseG $ split . f+ where split x = (x, x)++dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d+dot = (.) . (.)++-- | State monad for keeping track of what values have already been computed+type Done k v = State (Map k v)+type DoneA k v = Done k v v++-- | If the value has already been computed, return that, otherwise compute it!+ifNotDoneG :: Ord k => k -> (v -> a) -> Done k v a -> Done k v a+ifNotDoneG k ifDone action = do+ done <- getDone k+ case done of+ Just x -> return $ ifDone x+ Nothing -> action++-- | See if a value has been computed already.+getDone :: Ord k => k -> Done k v (Maybe v)+getDone = gets . M.lookup++-- | If the value has already been computed, return that, otherwise compute it!+ifNotDone :: Ord k => k -> DoneA k v -> DoneA k v+ifNotDone = flip ifNotDoneG id++-- | Insert a value into the map of computed values.+putDone :: Ord k => k -> v -> Done k v ()+putDone = modify `dot` M.insert++-- | Get the result.+evalDone :: Done k v a -> a+evalDone = flip evalState M.empty++-- | Convert a mapping to an array.+-- Uses 'minimum' and 'maximum', which means that the Ix and Num instances+-- must comply.+class IxMinMax a where+ ixMax :: [a] -> a+ ixMin :: [a] -> a++instance IxMinMax Int where+ ixMax = maximum+ ixMin = minimum++instance (IxMinMax a, IxMinMax b) => IxMinMax (a, b) where+ ixMax xs = (ixMax fs, ixMax ss)+ where (fs, ss) = unzip xs+ ixMin xs = (ixMin fs, ixMin ss)+ where (fs, ss) = unzip xs++-- | Convert a list of mappings to an array using the IxMinMax instance to+-- determine the array bounds.+listToArr :: (IxMinMax k, Ix k) => v -> [(k, v)] -> Array k v+listToArr def ass = accumArray (flip const) def (ixMin keys, ixMax keys) ass+ where keys = map fst ass
+ Data/Parser/Grempa/Aux/MultiMap.hs view
@@ -0,0 +1,39 @@+-- | A Map mapping multiple values to a key (cross between Map and Set).+-- This is not a complete module.+module Data.Parser.Grempa.Aux.MultiMap+ ( MultiMap+ , lookup+ , insert+ , inserts+ , union+ , unions+ , fromList+ , M.empty+ ) where++import qualified Data.Map as M+import Data.Map(Map)+import Prelude hiding (lookup)+import Data.Maybe+import qualified Data.Set as S+import Data.Set(Set)++type MultiMap k a = Map k (Set a)++lookup :: Ord k => k -> MultiMap k a -> Set a+lookup k m = fromMaybe S.empty $ M.lookup k m++insert :: (Ord a, Ord k) => k -> a -> MultiMap k a -> MultiMap k a+insert k v m = M.insert k (S.insert v (lookup k m)) m++inserts :: (Ord a, Ord k) => k -> Set a -> MultiMap k a -> MultiMap k a+inserts k v m = M.insert k (v `S.union` lookup k m) m++union :: (Ord a, Ord k) => MultiMap k a -> MultiMap k a -> MultiMap k a+union m1 m2 = foldl (flip $ uncurry inserts) m1 $ M.toList m2++unions :: (Ord a, Ord k) => [MultiMap k a] -> MultiMap k a+unions = foldl union M.empty++fromList :: (Ord a, Ord k) => [(k, a)] -> MultiMap k a+fromList = foldl (flip $ uncurry insert) M.empty
+ Data/Parser/Grempa/Dynamic.hs view
@@ -0,0 +1,7 @@+-- | Create parsers from grammars dynamically (at runtime).+module Data.Parser.Grempa.Dynamic+ ( module Data.Parser.Grempa.Parser.Dynamic+ , module Data.Parser.Grempa.Parser.Result+ ) where+import Data.Parser.Grempa.Parser.Dynamic+import Data.Parser.Grempa.Parser.Result
+ Data/Parser/Grempa/Grammar.hs view
@@ -0,0 +1,124 @@+{- | Grammar construction combinators.++ A grammar in grempa consists of a number of rules and an entry rule.+ Constructing a grammar is similar to doing it in BNF, but the grammars+ also have the information of what semantic action to take when a production+ has been found, which is used by the parsers that can be generated from the+ grammars.++ Rules, constructed with the 'rule' function, consist of lists of productions.++ A production in Grempa starts with a function which acts as the semantic+ action to be taken when that production has been parsed. After the '<@>'+ operator follows what the production accepts, which consists of a number of+ grammar symbols (terminals (tokens) or non-terminals (grammar rules)).++ The two combinator functions that construct productions come in two flavours+ each: One that signals that the result from parsing the symbol to the right+ of it should be used in the semantic action function and one that signals+ that it should not:++ @action '<@>' symbol =@ An action function followed by a symbol++ @action '<@' symbol =@ An action function followed by a symbol which will+ not be used when taking the semantic action of the+ production.++ @prod '<#>' symbol = @A production followed by a symbol++ @prod '<#' symbol = @A production followed by a symbol which will not be+ used when taking the semantic action of the+ production.+ The grammars have the type @'Grammar' t a@, which tells us that the grammar+ describes a language operating on @[t]@ returning @a@.++ Grammars can be recursively defined by using recursive do-notation.+-}++{-# LANGUAGE DoRec, TypeFamilies #-}+module Data.Parser.Grempa.Grammar+ ( module Data.Parser.Grempa.Grammar.Typed+ , several0, several, severalInter0, severalInter, cons+ ) where+import Data.Typeable+import Data.Parser.Grempa.Grammar.Typed+ (Grammar, rule, ToSym(..), (<#>), (<#), (<@>), (<@), epsilon)++-- | Create a new rule which consists of 0 or more of the argument symbol.+-- Example: @several0 x@ matches @x x ... x@+--+-- Creates one new rule.+several0 :: (ToSym s x, ToSymT s x ~ a, Typeable a, Typeable s)+ => x -> Grammar s [a]+several0 x = do+ rec+ xs <- rule [epsilon []+ ,(:) <@> x <#> xs]+ return xs++-- | Return a new rule which consists of 1 or more of the argument symbol.+-- Example: @several x@ matches @x x ... x@+--+-- Creates two new rules.+several :: (ToSym s x, ToSymT s x ~ a, Typeable a, Typeable s)+ => x -> Grammar s [a]+several x = do+ rec+ xs0 <- several0 x+ xs <- x `cons` xs0+ return xs++-- | Create a new rule which consists of a list of size 0 or more interspersed+-- with a symbol.+-- Example: @severalInter0 ';' x@ matches @x ';' x ';' ... ';' x@+-- If @x :: a@ then the result is of type @[a]@.+--+-- Creates one new rule.+severalInter0 :: ( ToSym s x, ToSymT s x ~ a+ , ToSym s t, ToSymT s t ~ s+ , Typeable a, Typeable s)+ => t -> x -> Grammar s [a]+severalInter0 tok x = do+ rec+ xs <- rule [epsilon []+ ,(:[]) <@> x+ ,(:) <@> x <# tok <#> xs]+ return xs++-- | Return a new rule which consists of a list of size 1 or more interspersed+-- with a symbol.+-- Example: @severalInter ';' x@ matches @x ';' x ';' ... ';' x@+--+-- Creates two new rules.+severalInter :: ( ToSym s x, ToSymT s x ~ a+ , ToSym s t, ToSymT s t ~ s+ , Typeable a, Typeable s)+ => t -> x -> Grammar s [a]+severalInter tok x = do+ rec+ xs0 <- severalInter0 tok x+ --xs <- (x <# tok) `cons` xs0+ xs <- rule [(:) <@> x <# tok <#> xs0]+ return xs++-- | Takes two symbols and combines them with @(:)@.+--+-- Creates one new rule.+--+-- This can for example be used instead of using both 'several' and 'several0'+-- on the same symbol, as that will create three new rules, whereas the+-- equivalent using 'cons' will only create two new rules. Example+-- transformation:+--+-- > xs0 <- several0 x+-- > xs <- several x+-- > ==>+-- > xs0 <- several0 x+-- > xs <- x `cons` xs0+cons :: ( ToSym s x, ToSymT s x ~ a+ , ToSym s xs, ToSymT s xs ~ [a]+ , Typeable a, Typeable s)+ => x -- ^ Symbol of type @a@+ -> xs -- ^ Symbol of type @[a]@+ -> Grammar s [a]+cons x xs = rule [(:) <@> x <#> xs]
+ Data/Parser/Grempa/Grammar/Token.hs view
@@ -0,0 +1,41 @@+-- | The token datatypes used internally in the parser generators.+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, UndecidableInstances, FlexibleInstances #-}+module Data.Parser.Grempa.Grammar.Token+ ( Tok(..)+ , tokToString+ , ETok(..)+ , Token+ ) where++import Data.Typeable+import Data.Data+import Language.Haskell.TH.Lift++-- | A Tok is either a token or 'EOF'.+data Tok t = Tok {unTok :: t}+ | EOF+ deriving (Eq, Ord, Show, Data, Typeable)++$(deriveLift ''Tok)++instance Functor Tok where+ fmap f (Tok s) = Tok (f s)+ fmap _ EOF = EOF++-- | Show the token in a more readable way. Used for error messages.+tokToString :: Show s => Tok s -> String+tokToString (Tok s) = show s+tokToString EOF = "EOF"++-- Data type for token or epsilon (empty).+data ETok s = ETok {unETok :: s}+ | Epsilon+ deriving (Eq, Ord, Show)++instance Functor ETok where+ fmap f (ETok s) = ETok (f s)+ fmap _ Epsilon = Epsilon++-- | Shorthand class for instances of Data, Ord and Show.+class (Data s, Ord s, Show s) => Token s where+instance (Data s, Ord s, Show s) => Token s where
+ Data/Parser/Grempa/Grammar/Typed.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE GADTs, DoRec, DeriveDataTypeable, TypeFamilies, FlexibleInstances, MultiParamTypeClasses #-}+{-# OPTIONS_HADDOCK hide #-}+module Data.Parser.Grempa.Grammar.Typed+ ( Grammar+ , Prod(..), Symbol(..), RId(..)+ , GrammarState+ , rule+ , evalGrammar+ , augment+ , getFun+ , ToSym(..)+ , (<@>), (<@)+ , (<#>), (<#)+ , epsilon) where++import Control.Monad.State+import Data.Data+import Data.Dynamic++import Data.Parser.Grempa.Parser.Table++type Rule t a = [Prod t a]++-- Inspired by ChristmasTree+-- | A grammar production+data Prod t a where+ -- Sequence a production and a symbol.+ PSeq :: Prod t (b -> a) -> Symbol t b -> Prod t a+ -- Sequence where the result of the symbol does not matter.+ PSeqN :: Prod t a -> Symbol t b -> Prod t a+ -- The semantic action combining a production into a result.+ PFun :: Typeable a => a -> Prod t a+ deriving Typeable++-- | A grammar symbol+data Symbol t a where+ -- A terminal (token).+ STerm :: t -> Symbol t t+ -- A reference to a grammar rule.+ SRule :: RId t a -> Symbol t a++-- | Rule ID+data RId s a where+ RId :: (Typeable t, Typeable a)+ => {rId :: RuleI, rIdRule :: Rule t a} -> RId t a+ deriving Typeable++-- The grammar monad giving a unique RuleI to each new rule+newtype RuleIDs t = RuleIDs { rules :: [RuleI] }+type GrammarState t a = State (RuleIDs t) a+type Grammar t a = GrammarState t (RId t a)++-- | Get the result from a Grammar computation+evalGrammar :: GrammarState t a -> a+evalGrammar = flip evalState (RuleIDs [0..])++-- | Create an augmented grammar (with a new start symbol)+augment :: (Typeable t, Typeable a) => Grammar t a -> Grammar t a+augment g = do+ rec+ s <- rule [id <@> r]+ r <- g+ return s++-- | Get the semantic action from a production+getFun :: Prod t a -> DynFun+getFun = getFun' []+ where+ getFun' :: [Bool] -> Prod s a -> DynFun+ getFun' as prod = case prod of+ PFun f -> DynFun (toDyn f) as+ PSeq p _ -> getFun' (True :as) p+ PSeqN p _ -> getFun' (False:as) p++-- | Create a new rule in a grammar+rule :: (Typeable a, Typeable t) => Rule t a -> Grammar t a+rule r = do+ st <- get+ let i:is = rules st+ put st {rules = is}+ return $ RId i r++-- | Class for writing grammars in a nicer syntax.+-- This class allows one to use both rules and tokens with the grammar+-- combinator functions. For the grammars to typecheck, it is often necessary+-- to give their type.+class ToSym t a where+ type ToSymT t a :: *+ toSym :: a -> Symbol t (ToSymT t a)++instance ToSym t t where+ type ToSymT t t = t+ toSym = STerm++instance ToSym t (RId t a) where+ type ToSymT t (RId t a) = a+ toSym = SRule++instance ToSym t (Symbol t a) where+ type ToSymT t (Symbol t a) = a+ toSym = id++-- * Combinator functions+-- | Sequence a production and a grammar symbol, where the symbol directly to+-- the right of the operator is used in the semantic action.+infixl 3 <#>+(<#>) :: (ToSym t x, ToSymT t x ~ b)+ => Prod t (b -> a) -> x -> Prod t a+p <#> q = PSeq p $ toSym q++-- | Sequence a production and a grammar symbol, where the symbol directly to+-- the right of the operator is not used in the semantic action.+infixl 3 <#+(<#) :: ToSym t x+ => Prod t a -> x -> Prod t a+p <# q = PSeqN p $ toSym q++-- | Start a production, where the symbol directly to the right of the operator+-- is used in the semantic action.+infixl 3 <@>+(<@>) :: (ToSym t x, ToSymT t x ~ b, Typeable a, Typeable b)+ => (b -> a) -- ^ The semantic action function for the production+ -> x -- ^ A grammar symbol+ -> Prod t a+f <@> p = PSeq (PFun f) $ toSym p++-- | Start a production, where the symbol directly to the right of the operator+-- is not used in the semantic action.+infixl 3 <@+(<@) :: (ToSym t x, Typeable a)+ => a -- ^ The semantic action function for the production+ -> x -- ^ A grammar symbol+ -> Prod t a+f <@ p = PSeqN (PFun f) $ toSym p++-- | The empty production, taking the semantic action (in this case just the+-- value to return) as the argument.+epsilon :: Typeable a => a -> Prod t a+epsilon c = PFun c
+ Data/Parser/Grempa/Grammar/Untyped.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE GADTs, DoRec #-}+module Data.Parser.Grempa.Grammar.Untyped+ ( Rule, Prod, Symbol(..), RId(..)+ , unType+ , rules, terminals, nonTerminals+ , first, firstProd, follow+ )where++import qualified Control.Arrow as A+import Control.Applicative+import Control.Monad.State+import qualified Data.Map as M+import Data.Map(Map)+import Data.Set(Set)+import qualified Data.Set as S++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Grammar.Token+import qualified Data.Parser.Grempa.Grammar.Typed as T++-- | The recursive data types for untyped grammars+type Rule s = [Prod s]+type Prod s = [Symbol s]++data Symbol s+ = STerm s+ | SRule (RId s)+ deriving (Eq, Ord, Show)++data RId s = RId {rId :: RuleI, rIdRule :: Rule s}++instance Show (RId s) where+ show (RId i _) = show i+instance Eq (RId s) where+ RId i _ == RId j _ = i == j+instance Ord (RId s) where+ RId i _ `compare` RId j _ = i `compare` j++type UnTypeState s' = State (Map Int (RId s'), ProdFunTable)+-- | Returns an untyped tree representation of a typed grammar+-- together with a mapping from rule and production number to+-- a dynamic containing the construction function of the typed+-- production+unType :: (s -> s') -> T.RId s a -> (RId s', ProdFunTable)+unType cs = A.second snd . flip runState (M.empty, []) . unTypeR cs+ where+ unTypeR :: (s -> s') -> T.RId s a -> UnTypeState s' (RId s')+ unTypeR c (T.RId i r) = do+ (rids, funs) <- get+ case M.lookup i rids of+ Just x -> return x+ Nothing -> do+ let newfuns = zip (zip (repeat i) [0..])+ (map T.getFun r)+ rec+ put (M.insert i res rids, funs ++ newfuns)+ res <- RId i <$> mapM (unTypeP c) r+ return res+ unTypeP :: (s -> s') -> T.Prod s a -> UnTypeState s' (Prod s')+ unTypeP c p = case p of+ T.PSeq ps s -> liftM2 (++) (unTypeP c ps) ((:[]) <$> unTypeS c s)+ T.PSeqN ps s -> liftM2 (++) (unTypeP c ps) ((:[]) <$> unTypeS c s)+ T.PFun _ -> return []+ unTypeS :: (s -> s') -> T.Symbol s a -> UnTypeState s' (Symbol s')+ unTypeS c s = case s of+ T.STerm t -> return $ STerm (c t)+ T.SRule r -> SRule <$> unTypeR c r+++instance Functor RId where+ fmap = flip evalState M.empty `dot` fmapR+ where+ fmapS :: (a -> b) -> Symbol a -> Done (RId a) (RId b) (Symbol b)+ fmapS f (STerm s) = return $ STerm $ f s+ fmapS f (SRule r) = do+ done <- getDone r+ case done of+ Just r' -> return $ SRule r'+ Nothing -> do+ rec+ putDone r res+ res <- fmapR f r+ return $ SRule res+ fmapR :: (a -> b) -> RId a -> DoneA (RId a) (RId b)+ fmapR f (RId n r) = RId n <$> mapM (mapM (fmapS f)) r++-------------------------------------------------------------------------------+-- | Get all rules from a grammar by following a rule's non-terminals recursively+rules :: Token s => RId s -> [RId s]+rules = S.toList . recTraverseG rules' . S.singleton+ where+ rules' rs = (res `S.union` rs, res)+ where+ res = S.unions $ map aux (S.toList rs)+ aux (RId _ r) = S.fromList [rid | p <- r, SRule rid <- p]++-- | Get all terminals (input symbols) from a list of rule IDs+terminals :: Token s => [RId s] -> [Symbol s]+terminals = concatMap (\(RId _ rs) -> [STerm s | as <- rs, STerm s <- as])++-- | Get all non-terminals (variables) from a list of rule IDs+nonTerminals :: Token s => [RId s] -> [Symbol s]+nonTerminals = map SRule++-- | Get the first tokens that a symbol eats+first :: Token s => Symbol s -> Set (ETok s)+first = evalDone . first'++--first' :: Token s => Symbol s -> Done (RId s) () (Set (ETok s))+first' :: Token s => Symbol s -> DoneA (RId s) (Set (ETok s))+first' (STerm s) = return $ S.singleton (ETok s)+first' (SRule rid@(RId _ r)) = ifNotDone rid $ do+ rec+ putDone rid $ case Epsilon `S.member` res of+ True -> S.singleton Epsilon+ False -> S.empty+ res <- S.unions <$> mapM firstProd' r+ return res++-- | Get the first tokens of a production+firstProd :: Token s => Prod s -> Set (ETok s)+firstProd = evalDone . firstProd'++firstProd' :: Token s => Prod s -> DoneA (RId s) (Set (ETok s))+firstProd' [] = return $ S.singleton Epsilon+firstProd' (x:xs) = do+ fx <- first' x+ case Epsilon `S.member` fx of+ True -> S.union (S.delete Epsilon fx) <$> firstProd' xs+ False -> return fx++-- | Get all symbols that can follow a rule,+-- also given the start rule and a list of all rules+follow :: Token s => RId s -> RId s -> [RId s] -> Set (Tok s)+follow rid = evalDone `dot` follow' rid++follow' :: Token s => RId s -> RId s -> [RId s] -> Done (RId s) () (Set (Tok s))+follow' rid startrid rids = ifNotDoneG rid (const S.empty) $ do+ putDone rid ()+ (if rid == startrid then S.insert EOF else id)+ <$> S.unions+ <$> sequence [followProd prod a+ | a@(RId _ prods) <- rids+ , prod <- prods]+ where+ followProd [] _ = return S.empty+ followProd (b:beta) a+ | b == SRule rid = case Epsilon `S.member` firstbeta of+ True -> (rest `S.union`) <$> follow' a startrid rids+ False -> return rest+ | otherwise = followProd beta a+ where+ firstbeta = firstProd beta+ rest = S.map (Tok . unETok) $ S.delete Epsilon firstbeta
+ Data/Parser/Grempa/Parser/Conflict.hs view
@@ -0,0 +1,45 @@+-- | Check parse tables for conflicts and resolve them.+module Data.Parser.Grempa.Parser.Conflict+ ( Conflict+ , conflicts+ , showConflict+ ) where++import qualified Control.Arrow as A+import Data.Function+import Data.List++import Data.Parser.Grempa.Grammar.Token+import Data.Parser.Grempa.Parser.Table++type Conflict t = (StateI, [[(Tok t, Action t)]])++-- | Check an action table to see if there are any conflicts.+-- If there is a conflict, try to resolve it.+conflicts :: Ord t+ => ActionTable t+ -- ^ Input table with potential conflicts+ -> (ActionTable t, [Conflict t])+ -- ^ Corrected action table, and its conflicts+conflicts tab = (tab', cs)+ where+ cs = filter (not . null . snd)+ [(st, filter ((>=2) . length)+ $ groupBy ((==) `on` fst)+ $ nub+ $ sort acts)+ | (st, (acts, _)) <- tab]+ tab' = map (A.second (A.first (nub . sort))) tab++-- | Show a conflict in a readable way+showConflict :: Show t => Conflict t -> String+showConflict (st, confs)+ = "Warning: Conflicts in action table (state " ++ show st+ ++ "), between " ++ intercalate " and " (map go confs)+ where+ go cs = "[" ++ intercalate "," (map go' cs) ++ "]"+ go' (t, a) = "On token " ++ show (unTok t) ++ " " ++ showAction a+ showAction (Shift s) = "shift state " ++ show s+ showAction (Reduce r p _ _) = "reduce (rule " ++ show r ++ ", production " ++ show p ++ ")"+ showAction Accept = "accept"+ showAction (Error {}) = "error"
+ Data/Parser/Grempa/Parser/Driver.hs view
@@ -0,0 +1,54 @@+module Data.Parser.Grempa.Parser.Driver+ ( driver+ , resultDriver+ , ReductionTree+ ) where++import Control.Applicative+import Data.Dynamic+import Data.List+import Data.Maybe++import Data.Parser.Grempa.Parser.Result+import Data.Parser.Grempa.Parser.Table+import qualified Data.Parser.Grempa.Grammar.Typed as T+import Data.Parser.Grempa.Grammar.Token++-- | Data type for reduction trees output by the driver+data ReductionTree s+ = RTReduce RuleI ProdI [ReductionTree s]+ | RTTerm s+ deriving Show++rtToTyped :: Token s => (s' -> s) -> ProdFunFun -> ReductionTree s' -> Dynamic+rtToTyped unc _ (RTTerm s) = toDyn (unc s)+rtToTyped unc funs (RTReduce r p tree) = applDynFun fun l+ where+ l = map (rtToTyped unc funs) tree+ fun = funs r p++driver :: Token s => (ActionFun s, GotoFun s, StateI) -> [s]+ -> ParseResult s (ReductionTree s)+driver (actionf, gotof, start) input =+ driver' [start] (map Tok input ++ [EOF]) [] [] (0 :: Integer)+ where+ driver' stack@(s:_) (a:rest) rt ests pos =+ case actionf s a of+ Shift t -> driver' (t : stack) rest (RTTerm (unTok a) : rt) [] (pos + 1)+ Reduce rule prod len es -> driver' (got : stack') (a : rest) rt' (es ++ ests) pos+ where+ stack'@(t:_) = drop len stack+ got = gotof t rule+ rt' = RTReduce rule prod (reverse $ take len rt) : drop len rt+ Accept -> Right $ head rt+ Error es -> Left $ ParseError (nub $ es ++ ests) pos+ driver' _ _ _ _ pos = Left $ InternalParserError pos++type RTParseResult s = ParseResult s (ReductionTree s)++resultDriver :: (Token s, Typeable a)+ => (s' -> s) -> ProdFunTable -> T.Grammar s a -> RTParseResult s' -> ParseResult s a+resultDriver unc funs _ rt = fromJust+ <$> fromDynamic+ <$> rtToTyped unc (prodFunToFun funs)+ <$> either (Left . fmap unc) Right rt
+ Data/Parser/Grempa/Parser/Dynamic.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK hide #-}+module Data.Parser.Grempa.Parser.Dynamic+ ( mkDynamicParser+ , constrWrapper+ , idWrapper+ ) where++import qualified Control.Arrow as A+import Data.Array+import Data.Data+import Data.Function+import qualified Data.Map as M+import Data.Maybe++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Parser.Driver+import Data.Parser.Grempa.Parser.LALR+import Data.Parser.Grempa.Parser.Result+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Grammar.Token+import qualified Data.Parser.Grempa.Grammar.Typed as T+import Data.Parser.Grempa.Grammar.Untyped++-- | Convert an action table to a function (operating on an array)+actToFun :: Ord t => ActionTable t -> ActionFun t+actToFun table st t = fromMaybe def $ M.lookup t stateTable+ where+ a = listToArr (M.empty, Error []) table'+ (stateTable, def) = if inRange (bounds a) st+ then a ! st+ else (M.empty, Error [])+ table' = map (A.second (A.first M.fromList)) table++-- | Convert an goto table to a function (operating on an array)+gotoToFun :: GotoTable t -> GotoFun t+gotoToFun table st rule = a ! (st, rule)+ where+ a = listToArr (-1) table++-- | Generate and run a dynamic parser, returning the result reduction tree+dynamicRT :: (Token t', Token t, Typeable a)+ => (t -> t') -- ^ Token wrapper+ -> T.Grammar t a -- ^ Language grammar+ -> [t] -- ^ Input token string+ -> T.GrammarState t (ParseResult t' (ReductionTree t'), ProdFunTable)+dynamicRT c g inp = do+ g' <- T.augment g+ let (unt, funs) = unType c g'+ (at,gt,st) = lalr unt+ res = driver (actToFun at, gotoToFun gt, st) $ map c inp+ return (res, funs)++-- | Make a parser at runtime given a grammar+mkDynamicParser :: (Token t, Token t', Typeable a)+ => (t -> t', t' -> t) -- ^ Token wrapper and unwrapper+ -> T.Grammar t a -- ^ Language grammar+ -> Parser t a+mkDynamicParser (c, unc) g inp =+ let (res, funs) = T.evalGrammar $ dynamicRT c g inp+ in resultDriver unc funs g res++-- | Wrapper type for representing tokens only caring about the constructor.+-- The Eq and Ord instances for 'CTok' will only compare the constructors+-- of its arguments.+data CTok a = CTok {unCTok :: a}+ deriving (Show, Data, Typeable)++instance Token a => Eq (CTok a) where+ CTok x == CTok y = ((==) `on` toConstr) x y++instance Token a => Ord (CTok a) where+ CTok x `compare` CTok y = case ((==) `on` toConstr) x y of+ True -> EQ+ False -> x `compare` y++-- | Wrap the input tokens in the 'CTok' datatype, which has 'Eq' and 'Ord'+-- instances which only look at the constructors of the input values.+-- This is for use as an argument to 'mkDynamicParser'.+--+-- Example, which will evaluate to @True@:+--+-- > CTok (Just 1) == CTok (Just 2)+--+-- This is useful when using a lexer that may give back a list of something+-- like:+--+-- > data Token = Ident String | Number Integer | LParen | RParen | Plus | ...+--+-- If you want to specify a grammar that accepts any @Ident@ and any @Number@+-- and not just specific ones, use 'constrWrapper'.+constrWrapper :: (t -> CTok t, CTok t -> t)+constrWrapper = (CTok, unCTok)++-- | Don't wrap the input tokens.+-- This is for use as an argument to 'mkDynamicParser'.+-- An example usage of 'idWrapper' is if the parser operates directly on+-- 'String'.+idWrapper :: (t -> t, t -> t)+idWrapper = (id, id)
+ Data/Parser/Grempa/Parser/Item.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.Parser.Grempa.Parser.Item+ ( It(..), getItProd, isKernelIt+ , kernel+ , nextSymbol+ , goto+ , nextItPos+ , Gen, GenData(..), runGen, gen+ , askItemSet+ ) where++import Control.Applicative+import Control.Monad.Reader+import Data.List+import Data.Map(Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Set(Set)+import qualified Data.Set as S++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Grammar.Untyped+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Grammar.Token++class (Eq (i s), Ord (i s), Show (i s), Token s) => It i s where+ itRId :: i s -> RId s+ itProd :: i s -> ProdI+ getItPos :: i s -> Int+ setItPos :: i s -> Int -> i s+ closure :: Set (i s) -> Set (i s)+ startItem :: RId s -> i s++getItProd :: It i s => i s -> Prod s+getItProd i = rIdRule (itRId i) !! itProd i++isKernelIt :: It i s => RId s -> i s -> Bool+isKernelIt st it = pos > 0 || (itRId it == st && pos == 0)+ where pos = getItPos it++kernel :: It i s => RId s -> Set (i s) -> Set (i s)+kernel st = S.filter $ isKernelIt st++-- | Return the symbol to the right of the "dot" in the item+nextSymbol :: It i s => i s -> Tok (Symbol s)+nextSymbol i+ | pos < length prod = Tok $ prod !! pos+ | otherwise = EOF+ where prod = getItProd i+ pos = getItPos i++-- | Determine the state transitions in the parsing+goto :: (It i s, Token s) => Set (i s) -> Symbol s -> Set (i s)+goto is s = closure $ setFromJust $ S.map (nextTest s) is+ where+ nextTest x i+ | nextSymbol i == Tok x = Just $ nextItPos i+ | otherwise = Nothing++nextItPos :: It i s => i s -> i s+nextItPos i = setItPos i $ getItPos i + 1++-- | The sets of items for a grammar+itemSets :: (It i s, Token s) => RId s -> [RId s] -> Set (Set (i s))+itemSets rid rids = S.delete S.empty $ recTraverseG itemSets' c1+ where+ c1 = S.singleton $ closure $ S.singleton $ startItem rid+ symbols = terminals rids ++ nonTerminals rids+ itemSets' c = (c `S.union` gs, gs)+ where gs = S.fromList [goto i x | i <- S.toList c, x <- symbols]++data GenData i s = GenData+ { gItemSets :: [(Set (i s), StateI)]+ , gItemSetIndex :: Map (Set (i s)) StateI+ , gRules :: [RId s]+ , gTerminals :: [Symbol s]+ , gNonTerminals :: [Symbol s]+ , gSymbols :: [Symbol s]+ , gStartState :: Int+ , gStartRule :: RId s+ } deriving Show++type Gen i s = Reader (GenData i s)+runGen :: Gen i s a -> GenData i s -> a+runGen = runReader++gen :: (It i s, Token s) => RId s -> GenData i s+gen g = GenData is ix rs ts nt sys ss g+ where+ is = zip (S.toList $ itemSets g rs) [0..]+ ix = M.fromList is+ rs = rules g+ ts = terminals rs+ nt = nonTerminals rs+ sys = ts ++ nt+ ss = snd $ fromMaybe (error "gen: maybe")+ $ find (S.member (startItem g) . fst) is+++askItemSet :: (It i s, Token s) => Set (i s) -> Gen i s (Maybe StateI)+askItemSet x | x == S.empty = return Nothing+askItemSet x = do+ res <- M.lookup x <$> asks gItemSetIndex+ case res of+ Just r -> return $ Just r+ Nothing -> do+ is <- asks gItemSets+ return $ snd <$> listToMaybe (filter (S.isSubsetOf x . fst) is)
+ Data/Parser/Grempa/Parser/LALR.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE TupleSections, DoRec, FlexibleInstances, MultiParamTypeClasses #-}+module Data.Parser.Grempa.Parser.LALR+ ( lalr+ ) where++import Control.Applicative+import qualified Control.Arrow as A+import Control.Monad.Reader+import qualified Data.Map as M+import Data.Maybe+import Data.Set(Set)+import qualified Data.Set as S++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Parser.Item+import Data.Parser.Grempa.Aux.MultiMap(MultiMap)+import qualified Data.Parser.Grempa.Aux.MultiMap as MM+import qualified Data.Parser.Grempa.Parser.SLR as SLR+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Grammar.Token+import Data.Parser.Grempa.Grammar.Untyped++data Item s =+ Item { itemRId :: RId s+ , itemProd :: Int+ , itemPos :: Int+ , itemLA :: Tok s+ }+ deriving (Eq, Ord)++instance Show s => Show (Item s) where+ show (Item r pr po la) = "It(" ++ show r +++ "," ++ show pr +++ "," ++ show po +++ "," ++ show la ++ ")\n"+++instance Token s => It Item s where+ itRId = itemRId+ itProd = itemProd+ getItPos = itemPos+ setItPos i p = i {itemPos = p}+ closure = closureLR1+ startItem rid = Item rid 0 0 EOF+++-- | Determine what items may be valid productions from an item+closureLR1 :: Token s => Set (Item s) -> Set (Item s)+closureLR1 = recTraverseG closure'+ where+ closure' is = (is `S.union` res, res)+ where res = S.unions $ map closureI $ S.toList is+ closureI i = case nextSymbol i of+ Tok (SRule rid) -> S.unions [firstItems rid b | b <- firstA beta (itemLA i)]+ where beta = drop (getItPos i + 1) (getItProd i)+ _ -> S.empty+ firstA prod sym = let f = firstProd prod in+ if Epsilon `S.member` f+ then S.toList (S.insert sym $ unETokSet f)+ else map (Tok . unETok) $ S.toList f+ unETokSet = S.map (Tok . unETok) . S.delete Epsilon+ -- | Get the items with the dot at the beginning from a rule+ firstItems :: Token s => RId s -> Tok s -> Set (Item s)+ firstItems rid@(RId _ prods) a = S.fromList+ $ map (\p -> Item rid p 0 a)+ [0..length prods - 1]++data Lookahead s+ = Spont (Tok s)+ | PropFrom Int (SLR.Item s)+ deriving (Eq, Ord, Show)++-- Using Maybe where Nothing represents a symbol not in the grammar+type LookaheadTable s = MultiMap (Int, SLR.Item (Maybe s))+ (Lookahead (Maybe s))++-- | Compute how the lookaheads propagate+lookaheads :: Token s+ => Int+ -> Set (SLR.Item (Maybe s))+ -> Set (SLR.Item (Maybe s))+ -> Symbol (Maybe s)+ -> Gen SLR.Item (Maybe s) (LookaheadTable s)+lookaheads istate i k x = do+ mjstate <- askItemSet (goto i x)+ case mjstate of+ Nothing -> return MM.empty+ Just jstate -> do+ startSt <- asks gStartState+ startRId <- asks gStartRule+ let startIt = startItem startRId+ return $ MM.insert (startSt, startIt) (Spont EOF)+ $ MM.unions+ $ map (MM.fromList . lookaheadsI jstate)+ $ S.toList k+ where+ lookaheadsI jstate a+ = [case itemLA b /= Tok Nothing of+ True -> ((jstate, nextItPos $ fromLALR b), Spont $ itemLA b)+ False -> ((jstate, nextItPos $ fromLALR b), PropFrom istate a)+ | b <- S.toList js+ , nextSymbol b == Tok x]+ where js = closure $ S.singleton $ fromSLR a (Tok Nothing)++fromSLR :: SLR.Item s -> Tok s -> Item s+fromSLR (SLR.Item r prod pos) = Item r prod pos++fromLALR :: Item s -> SLR.Item s+fromLALR (Item r prod pos _) = SLR.Item r prod pos++-- | Find the lookaheads of an SLR Item+findLookaheads :: Token s+ => LookaheadTable s+ -> Int -> SLR.Item (Maybe s)+ -> Done (Int, SLR.Item (Maybe s)) () (Set (Tok (Maybe s)))+findLookaheads latable istate i =+ ifNotDoneG (istate, i) (const S.empty) $ do+ let las = MM.lookup (istate, i) latable+ putDone (istate, i) ()+ S.unions <$> mapM go (S.toList las)+ where+ go (Spont s) = return $ S.singleton s+ go (PropFrom st it) = findLookaheads latable st it++-- | Construct the LALR items from a set of SLR items+lalrItems :: Token s => Gen SLR.Item (Maybe s) [(Set (Item (Maybe s)), Int)]+lalrItems = do+ st <- asks gStartRule+ iss <- asks gItemSets+ let kss = map (A.first $ kernel st) iss+ syms <- asks gSymbols+ las <- zipWithM (\(i,n) (k,_) -> MM.unions <$> mapM (lookaheads n i k) syms) iss kss+ let tab = MM.unions las+ return+ [ let newi = [ evalDone $ toIts it <$> findLookaheads tab n it+ | it <- S.toList ks]+ in (closure $ S.fromList $ concat newi, n)+ | (ks, n) <- kss]+ where+ toIts it las = map (fromSLR it) $ remNothing las+ remNothing las = S.toList $ S.delete (Tok Nothing) las++slrGenToLalrGen :: Token s => GenData SLR.Item (Maybe s) -> GenData Item (Maybe s)+slrGenToLalrGen g = let newits = runGen lalrItems g+ in g { gItemSets = newits+ , gItemSetIndex = M.fromList newits+ }+-- | Create LALR parsing tables from a starting rule of a grammar (augmented)+lalr :: Token s => RId s -> (ActionTable s, GotoTable s, Int)+lalr g =+ let initSlr = gen (Just <$> g)+ initg = slrGenToLalrGen initSlr+ cs = gItemSets initg+ as = [runGen (actions i) initg | i <- cs]+ gs = concat [runGen (gotos i) initg | i <- cs]+ in (as, gs, gStartState initg)++-- | Create goto table+gotos :: Token s+ => (Set (Item (Maybe s)), StateI)+ -> Gen Item (Maybe s) [((StateI, RuleI), StateI)]+gotos (items, i) = do+ nt <- asks gNonTerminals+ map (A.first (i,)) <$> catMaybes <$> sequence+ [do j <- askItemSet $ goto items a+ return $ case j of+ Nothing -> Nothing+ Just x -> Just (ai, x)+ | a@(SRule (RId ai _)) <- nt]++-- | Create action table+actions :: Token s+ => (Set (Item (Maybe s)), StateI)+ -> Gen Item (Maybe s) (StateI, ([(Tok s, Action s)], Action s))+actions (items, i) = do+ start <- asks gStartRule+ let actions' item@Item {itemRId = rid@(RId ri _)} = case nextSymbol item of+ Tok a@(STerm (Just s)) -> do+ j <- askItemSet $ goto items a+ case j of+ Just x -> return [(Tok s, Shift x)]+ Nothing -> return []+ EOF+ | rid /= start ->+ return+ [ ( fromJust <$> itemLA item+ , Reduce ri (itProd item)+ (length $ getItProd item) [])]+ | itemLA item == EOF -> return [(EOF, Accept)]+ _ -> return []+ tab <- concat <$> sequence+ [actions' it | it <- S.toList items]+ return (i, (mapShifts tab, def (mapShifts tab)))+ where+ def tab = if null (reds tab)+ then Error $ keys $ shifts tab+ else head (elems $ reds tab)+ mapShifts tab = map (A.second $ addShifts $ keys $ shifts tab) tab+ where addShifts ss (Reduce r pr p _) = Reduce r pr p ss+ addShifts _ x = x+ shifts = filter (not . isReduce . snd)+ reds = filter (isReduce . snd)+ keys = map fst+ elems = map snd
+ Data/Parser/Grempa/Parser/Result.hs view
@@ -0,0 +1,59 @@+-- | The results from running Grempa on a grammar (i.e. a parser) and parsing+-- errors.+module Data.Parser.Grempa.Parser.Result+ ( ParseResult+ , Parser+ , ParseError(..)+ , showError+ , parse+ ) where++import Data.List++import Data.Parser.Grempa.Grammar.Token++-- | The result of running a parser+type ParseResult t a = Either (ParseError t) a++-- | The type of a parser generated by Grempa+type Parser t a = [t] -> ParseResult t a++-- | The different kinds of errors that can occur+data ParseError t+ -- | The parser did not get an accepted string of tokens.+ = ParseError+ { expectedTokens :: [Tok t] -- ^ A list of tokens that would have been+ -- acceptable inputs when the error occured.+ , position :: Integer -- ^ The position (index into the input+ -- token list) at which the error occured.+ }+ -- | This should not happen. Please file a bug report if it does.+ | InternalParserError+ { position :: Integer -- ^ The position at which something went+ -- horribly wrong.+ }+ deriving Show++instance Functor ParseError where+ fmap f (ParseError e p) = ParseError (map (fmap f) e) p+ fmap _ (InternalParserError p) = InternalParserError p++-- | Make a prettier error string from a 'ParseError'.+-- This shows the position as an index into the input string of tokens, which+-- may not always be preferable, as that position may differ to the position+-- in the input if it is first processed by a lexer.+-- It also shows the expected tokens.+showError :: Show t => ParseError t -> String+showError e = case e of+ ParseError ts pos -> "Parse error at " ++ show pos+ ++ ", expecting one of {"+ ++ intercalate "," (map tokToString ts) ++ "}."+ InternalParserError pos -> "Internal parser error at "+ ++ show pos ++ "."++-- | Throw away the 'Either' from the 'ParseResult' and throw an exception using+-- 'showError' if something went wrong.+parse :: Show t => Parser t a -> [t] -> a+parse p i = case p i of+ Left err -> error $ showError err+ Right res -> res
+ Data/Parser/Grempa/Parser/SLR.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE TupleSections, FlexibleInstances, MultiParamTypeClasses #-}+module Data.Parser.Grempa.Parser.SLR+ ( Item(..)+ , slr+ ) where+import Control.Applicative+import qualified Control.Arrow as A+import Control.Monad.Reader+import Data.Set(Set)+import qualified Data.Set as S+import Data.Maybe++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Parser.Item+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Grammar.Token+import Data.Parser.Grempa.Grammar.Untyped++data Item s =+ Item { itemRId :: RId s+ , itemProd :: Int+ , itemPos :: Int+ }+ deriving (Eq, Ord)++instance Show (Item s) where+ show (Item r pr po) = "It(" ++ show r +++ "," ++ show pr +++ "," ++ show po ++ ")"++instance Token s => It Item s where+ itRId = itemRId+ itProd = itemProd+ getItPos = itemPos+ setItPos i p = i {itemPos = p}+ closure = closureLR0+ startItem rid = Item rid 0 0++-- | Determine what items may be valid productions from an item+closureLR0 :: Token s => Set (Item s) -> Set (Item s)+closureLR0 = recTraverseG closure'+ where+ closure' is = (is `S.union` res, res)+ where res = S.unions $ map closureI (S.toList is)+ closureI i = case nextSymbol i of+ Tok (SRule rid) -> firstItems rid+ _ -> S.empty+ -- | Get the items with the dot at the beginning from a rule+ firstItems :: RId s -> Set (Item s)+ firstItems rid@(RId _ prods) = S.fromList+ $ map (\p -> Item rid p 0) [0..length prods - 1]++----------------------------------++-- | Create SLR parsing tables from a starting rule of a grammar (augmented)+slr :: Token s => RId s -> (ActionTable s, GotoTable s, Int)+slr g =+ let initg = gen g+ cs = gItemSets initg+ as = [runGen (actions i) initg | i <- cs]+ gs = concat [runGen (gotos i) initg | i <- cs]+ in (as, gs, gStartState initg)++-- | Create goto table+gotos :: Token s+ => (Set (Item s), StateI)+ -> Gen Item s [((StateI, RuleI), StateI)]+gotos (items, i) = do+ nt <- asks gNonTerminals+ map (A.first (i,)) <$> catMaybes <$> sequence+ [do j <- askItemSet (goto items a)+ return $ case j of+ Nothing -> Nothing+ Just x -> Just (ai, x)+ | a@(SRule (RId ai _)) <- nt]++-- | Create action table+actions :: Token s+ => (Set (Item s), StateI)+ -> Gen Item s (StateI, ([(Tok s, Action s)], Action s))+actions (items, i) = do+ start <- asks gStartRule+ rs <- asks gRules+ let actions' item@Item {itemRId = rid@(RId ri _)} = case nextSymbol item of+ Tok a@(STerm s) -> do+ j <- askItemSet $ goto items a+ case j of+ Just x -> return [(Tok s, Shift x)]+ Nothing -> return []+ EOF+ | rid /= start -> do+ let as = S.toList $ follow rid start rs+ return [(a, Reduce ri (itProd item) (length $ getItProd item) [])+ | a <- as]+ | otherwise -> return [(EOF, Accept)]+ _ -> return []+ tab <- concat <$> sequence+ [actions' it | it <- S.toList items]+ return (i, (mapShifts tab, def (mapShifts tab)))+ where+ def tab = if null (reds tab)+ then Error $ keys $ shifts tab+ else head $ elems $ reds tab+ mapShifts tab = map (A.second $ addShifts $ keys $ shifts tab) tab+ where addShifts ss (Reduce r pr p _) = Reduce r pr p ss+ addShifts _ x = x+ reds = filter (isReduce . snd)+ shifts = filter (not . isReduce . snd)+ keys = map fst+ elems = map snd
+ Data/Parser/Grempa/Parser/Static.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK hide #-}+-- | Make parsers at compile time using Template Haskell+module Data.Parser.Grempa.Parser.Static+ ( mkStaticParser+ , ToPat(..)+ , toConstrPat+ ) where++import Control.Applicative+import Control.Monad+import Data.Dynamic+import Data.Data+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Data.Parser.Grempa.Parser.Conflict+import Data.Parser.Grempa.Parser.Driver+import Data.Parser.Grempa.Parser.LALR+import Data.Parser.Grempa.Parser.Table+import qualified Data.Parser.Grempa.Grammar.Typed as T+import Data.Parser.Grempa.Grammar.Token+import Data.Parser.Grempa.Grammar.Untyped+import Data.Parser.Grempa.Parser.Result -- For Haddock!++-- | Make a function with a case expression from an action table+mkActFun :: (ToPat t, Data t, Lift t) => ActionTable t -> ExpQ+mkActFun tab = do+ st <- newName "st"+ tok <- newName "tok"+ lamE [varP st, varP tok]+ $ caseE (varE st)+ $ map (mkMatch tok) tab+ ++ [match wildP (normalB [|Error []|]) []]+ where+ mkMatch tok (st, (tokTab, def)) =+ match (toPat st) (normalB+ ( caseE (varE tok)+ $ map mkMatch' tokTab+ ++ [match wildP (normalB [|def|]) []]+ )) []+ mkMatch' (v, res) = match (toPat v) (normalB [|res|]) []++-- | Make a function with a case expression from a goto table+mkGotoFun :: GotoTable t -> ExpQ+mkGotoFun tab = do+ st <- newName "st"+ r <- newName "r"+ lamE [varP st, varP r]+ $ caseE (tupE [varE st, varE r])+ $ map mkMatch tab+ ++ [match wildP (normalB [|-1|]) []] -- Hacky (unknown goto is -1)+ where+ mkMatch (k, v) =+ match (toPat k) (normalB [|v|]) []++-- | Make a function returning the reduction tree from a grammar+staticRT :: (Typeable a, ToPat t, Token t, Lift t)+ => T.Grammar t a -> ExpQ+staticRT g = do+ let (res, confls) = T.evalGrammar $ do+ g' <- T.augment g+ let (unt, _) = unType id g'+ (at,gt,st) = lalr unt+ (at', ac) = conflicts at+ driv = [|driver ($(mkActFun at'), $(mkGotoFun gt), st)|]+ return (driv, ac)+ forM_ confls $ report False . showConflict+ res++-- | Make a static parser from a grammar.+--+-- Example usage:+--+-- > g :: Grammar s a+-- > gparser = $(mkStaticParser g [|g|])+--+-- Note that @gparser@ must be in a different module than @g@, due to+-- Template Haskell restrictions.+-- The token type of the grammar must also be an instance of 'ToPat', and the+-- result type an instance of 'Typeable' (the GHC extension+-- DeriveDataTypeable may be useful for this).+--+-- If there are conflicts in the parsing tables, they will be displayed+-- as warnings when compiling the parser.+mkStaticParser :: (Typeable a, ToPat t, Token t, Lift t)+ => T.Grammar t a -- ^ The grammar+ -> ExpQ -- ^ The Template Haskell representation of the+ -- grammar+ -> ExpQ -- ^ The representation of a parser of type + -- 'Parser' @t a@+mkStaticParser g gn = do+ drive <- newName "driver"+ inp <- newName "inp"+ let driverf = funD drive+ [clause [varP inp] (normalB [| $(staticRT g) $(varE inp) |]) []]+ letE [driverf] [| resultDriver id $funs $gn . $(varE drive) |]+ where+ funs = [| T.evalGrammar $ snd <$> unType id <$> T.augment $gn |]++-- | Make a Template Haskell pattern from a value.+-- This is used to create a case expression from a parsing table when using+-- 'mkStaticParser', and it is thus required that the token type that the+-- parser is to operate on is an instance of this class.+--+-- The parser will behave differently depending on how its 'ToPat' instance+-- works. If only comparing constructors ('toConstrPat'), it will regard+-- @Just 1@ as the same compared to @Just 2@.+--+-- 'toConstrPat' and "Language.Haskell.TH" can help in creating an instance.+class ToPat a where+ toPat :: a -> PatQ++instance ToPat Char where+ toPat = litP . charL++instance ToPat Int where+ toPat = litP . integerL . fromIntegral++instance (ToPat a, ToPat b) => ToPat (a, b) where+ toPat (x, y) = tupP [toPat x, toPat y]++instance ToPat a => ToPat (Tok a) where+ toPat (Tok x) = conP 'Tok [toPat x]+ toPat EOF = conP 'EOF []++instance ToPat a => ToPat [a] where+ toPat = listP . map toPat++-- | Automatically create a 'ToPat' instance which only compares the constructor+-- of the token type. For example, the pattern yielded from using this on the+-- value @Just 3@ is the pattern @Just _@.+--+-- Example usage:+--+-- > instance ToPat TokenType where+-- > toPat = toConstrPat+toConstrPat :: (Token t, Lift t) => t -> PatQ+toConstrPat tok = do+ let name = mkName $ tyconModule (dataTypeName $ dataTypeOf tok)+ ++ "." ++ show (toConstr tok)+ info <-reify name+ case info of+ DataConI n t _ _ -> conP n $ replicate (numArgs t) wildP+ x -> error $ "toConstrPat got " ++ show x+ where+ numArgs (AppT _ t2) = 1 + numArgs t2+ numArgs _ = 0
+ Data/Parser/Grempa/Parser/Table.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Parser.Grempa.Parser.Table+ ( StateI, RuleI, StackI, ProdI+ , Action(..)+ , unError+ , isReduce+ , ActionTable, GotoTable, ActionFun, GotoFun, ProdFunTable, ProdFunFun+ , prodFunToFun+ , DynFun(..), applDynFun+ )where++import Data.Array+import Data.Dynamic+import Language.Haskell.TH.Lift++import Data.Parser.Grempa.Aux.Aux+import Data.Parser.Grempa.Grammar.Token++type StateI = Int+type RuleI = Int+type StackI = Int+type ProdI = Int++-- | Data type used in the action table to determine the next+-- parsing action depending on the input and current state+data Action s = Accept+ | Error [Tok s]+ | Reduce RuleI ProdI StackI [Tok s]+ | Shift StateI+ deriving (Eq, Ord, Show)++unError :: Action s -> [Tok s]+unError (Error es) = es+unError _ = []++isReduce :: Action s -> Bool+isReduce (Reduce {}) = True+isReduce _ = False++$(deriveLift ''Action)++type ActionTable s = [(StateI, ([(Tok s, Action s)], Action s))]+type GotoTable s = [((StateI, RuleI), StateI)]++type ActionFun s = StateI -> Tok s -> Action s+type GotoFun s = StateI -> RuleI -> StateI++type ProdFunTable = [((RuleI, ProdI), DynFun)]+type ProdFunFun = RuleI -> ProdI -> DynFun++prodFunToFun :: ProdFunTable -> ProdFunFun+prodFunToFun table r p = a ! (r, p)+ where a = listToArr (error "prodFun") table++data DynFun = DynFun Dynamic [Bool]++applDynFun :: DynFun -> [Dynamic] -> Dynamic+applDynFun (DynFun f (b:bs)) (a:as)+ | b = applDynFun (DynFun (dynApp f a) bs) as+ | otherwise = applDynFun (DynFun f bs) as+applDynFun (DynFun f _) _ = f+
+ Data/Parser/Grempa/Static.hs view
@@ -0,0 +1,7 @@+-- | Create parsers from grammars statically (at compile time).+module Data.Parser.Grempa.Static+ ( module Data.Parser.Grempa.Parser.Static+ , module Data.Parser.Grempa.Parser.Result+ ) where+import Data.Parser.Grempa.Parser.Static+import Data.Parser.Grempa.Parser.Result
+ Data/Parser/Grempa/Test.hs view
@@ -0,0 +1,86 @@+-- | Generate arbitrary input strings for a grammar and see that it is+-- able to parse them.+module Data.Parser.Grempa.Test(prop_parser) where++import Control.Applicative+import qualified Control.Arrow as A+import Data.Dynamic+import Data.List+import Data.Maybe+import Test.QuickCheck++import qualified Data.Parser.Grempa.Grammar.Typed as T+import Data.Parser.Grempa.Grammar.Untyped+import Data.Parser.Grempa.Parser.Table+import Data.Parser.Grempa.Parser.Result++arb :: Typeable s => ProdFunFun -> RId s -> Int -> Gen ([s], Dynamic)+arb fun rid n = arbR n fun (rIdRule rid, rId rid)++arbR :: Typeable s => Int -> ProdFunFun -> (Rule s, RuleI) -> Gen ([s], Dynamic)+arbR n fun (prods, r) = do+ let (recs, nonRecs) = partition (isRec . fst3) $ index prods+ recsf = map (tup recf) recs+ nonRecsf = map (tup $ 10 * recf + 1) nonRecs+ freqs = map (A.second $ arbP (n - 1) fun) $ recsf ++ nonRecsf+ minn = if null nonRecs then 1 else 0+ recf = max n minn+ frequency freqs+ where+ index xs = zip3 xs [0..] $ repeat r+ fst3 (a,_,_) = a+ tup a b = (a, b)++arbP :: Typeable s => Int -> ProdFunFun -> (Prod s, RuleI, ProdI) -> Gen ([s], Dynamic)+arbP n fun (prod, p, r) = do+ (syms, dyns) <- A.first concat+ <$> unzip+ <$> mapM (arbS n fun) prod+ return (syms, applDynFun (fun r p) dyns)++arbS :: Typeable s => Int -> ProdFunFun -> Symbol s -> Gen ([s], Dynamic)+arbS _ _ (STerm s) = return ([s], toDyn s)+arbS n fun (SRule rid) = arb fun rid (n - 1)++isRec :: Prod s -> Bool+isRec = not . null . filter isRule+ where+ isRule (SRule {}) = True+ isRule _ = False++-- | QuickCheck property for seeing if a parser can parse everything produced+-- by a grammar and get the expected result.+--+-- There are cases where the property will fail even though the parser is+-- correct. That can happen when there is an 'epsilon' production that makes+-- it valid to make the result tree nest one more level without eating any of+-- the input. The parsers generated will not do this, but the random input+-- generator currently will (this is a bug).+-- An example of this is the following:+--+-- > data Expr = ... | EApp Expr [Expr]+-- > grammar = ...+-- > expr <- rule [...+-- > , EApp <@> expr <#> exprs+-- > ]+-- > exprs <- several expr+--+-- Here, the random generator may produce @EApp expr []@ for some @expr@,+-- as the rule 'several' @expr@ matches 0 or more @expr@s.+-- which will have the same input token string as just @expr@ which is what+-- the parser will parse, so the expected result and the parsed result will+-- differ.+prop_parser :: (Show a, Show s, Eq a, Typeable a, Typeable s)+ => Parser s a -- ^ Input parser+ -> T.Grammar s a -- ^ The grammar used to generate the parser+ -> Property+prop_parser parser grammar =+ let (rid, funs) = unType id $ T.evalGrammar grammar+ in forAll (A.second (fromJust . fromDynamic)+ <$> sized (arb (prodFunToFun funs) rid))+ (parseCorrect parser)++parseCorrect :: (Eq a) => Parser s a -> ([s], a) -> Bool+parseCorrect parser (inp, res) = case parser inp of+ Right parseres -> parseres == res+ Left _ -> False
+ Grempa.cabal view
@@ -0,0 +1,63 @@+Name: Grempa+Version: 0.1.0+Synopsis: Embedded grammar DSL and LALR parser generator+Description:+ A library for expressing programming language grammars in a form similar+ to BNF, which is extended with the semantic actions to take when+ a production has been parsed. The grammars are typed and are to be be used+ with the LALR(1) parser generator, also part of the library, which can+ generate a parser for the language either at compile time using Template+ Haskell, producing fast parsers with no initial runtime overhead, or+ dynamically, which has the initial overhead of generating the parser, but+ can be used for example when the grammar depends on an input.+License: BSD3+License-file: LICENSE+Author: Olle Fredriksson+Maintainer: fredriksson.olle@gmail.com+Copyright: (c) 2010 Olle Fredriksson+Stability: Experimental+Category: Parsing+Build-type: Simple+Extra-source-files: README+ , examples/Ex1SimpleExpr.hs+ , examples/Ex1SimpleExprParser.hs+ , examples/Ex2Calculator.hs+ , examples/Ex2CalculatorParser.hs+ , examples/Ex3Fun.hs+ , examples/Ex3FunLex.hs+ , examples/Ex3FunParser.hs+ , examples/Ex4Test.hs+Cabal-version: >= 1.6+Flag test+ Description:+ Build the module for generating random inputs and the expected output for+ your grammars.+ Default: False+Library+ Build-depends: array == 0.3.*+ , base == 4.2.*+ , containers == 0.3.*+ , monads-fd == 0.1.*+ , template-haskell == 2.4.*+ , th-lift == 0.5.*+ Exposed-modules: Data.Parser.Grempa.Grammar+ , Data.Parser.Grempa.Static+ , Data.Parser.Grempa.Dynamic+ Other-modules: Data.Parser.Grempa.Aux.Aux+ , Data.Parser.Grempa.Aux.MultiMap+ , Data.Parser.Grempa.Grammar.Token+ , Data.Parser.Grempa.Grammar.Typed+ , Data.Parser.Grempa.Grammar.Untyped+ , Data.Parser.Grempa.Parser.Conflict+ , Data.Parser.Grempa.Parser.Driver+ , Data.Parser.Grempa.Parser.Dynamic+ , Data.Parser.Grempa.Parser.Item+ , Data.Parser.Grempa.Parser.LALR+ , Data.Parser.Grempa.Parser.Result+ , Data.Parser.Grempa.Parser.SLR+ , Data.Parser.Grempa.Parser.Static+ , Data.Parser.Grempa.Parser.Table+ GHC-Options: -Wall+ if flag(test)+ Build-Depends: QuickCheck == 2.2.*+ Exposed-modules: Data.Parser.Grempa.Test
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Olle Fredriksson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Olle Fredriksson nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,45 @@+Grempa 0.1.0+Embedded grammar DSL and LALR parser generator+Author: Olle Fredriksson++* Building++ Use Cabal. Example:++ > cabal configure+ > cabal build+ > cabal install++* Documentation++ To generate the documentation for the different modules, use Cabal.++ > cabal configure+ > cabal haddock++ Also refer to the examples.++* Examples++ The examples directory contains examples of varying complexity and serves+ as an introduction to the usage of the library.++ The examples are numbered, which serves as a suggested reading order.++* Testing++ To also compile the module for generating random inputs and their expected+ outputs for your grammar, and testing a generated parser against that, use the+ test flag. Example:++ > cabal configure -ftest+ > cabal build+ > cabal install++* Bugs++ If you find a bug, please send a bug report to fredriksson.olle@gmail.com.++* License++ Refer to the file LICENSE in this directory.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Ex1SimpleExpr.hs view
@@ -0,0 +1,58 @@+-- | Example 1: Parsing simple expressions of the form @"x*(x+x)+x"@ with the+-- correct precedence levels.++-- Needed for recursive do notation.+{-# LANGUAGE DoRec #-}+-- Needed for deriving 'Typeable'.+{-# LANGUAGE DeriveDataTypeable #-}++module Ex1SimpleExpr where++-- First import the Grempa grammar combinators.+import Data.Parser.Grempa.Grammar+-- The result datatype must be an instance of the 'Typeable' typeclass.+-- Fortunately, it is possible to derive an instance. Using the extension+-- above.+import Data.Typeable++-- | The result data structure.+data E = Plus E E+ | Times E E+ | Var+ deriving (Show, Eq, Typeable)++-- | The type of the 'expr' function tells us that it is a grammar for a+-- language operating on lists of 'Char's returning an 'E' if the parsing+-- is successful.+expr :: Grammar Char E+expr = do+ -- Recursive do notation is used so that a rule defined before another rule+ -- can still use that other rule. This is not strictly necessary for all+ -- grammars, but for this one, it is.+ rec+ -- Here @e@ will be the name of a new rule in the grammar (@e@ for + -- expression).+ -- The semantic action to take when @e@ has been found is to build a result+ -- of type 'E' using the 'Plus' constructor. Since we're using '<#' before+ -- the '+', it means that the result from parsing that will not be applied+ -- to the 'Plus' constructor.+ e <- rule [ Plus <@> e <# '+' <#> t+ -- An @e@ can also be a @t@ (term, defined below) and then we just+ -- want to return that result, because @t@ will also have results+ -- of type @E@. So just use the identity function.+ , id <@> t+ ]+ -- Similar to @e@ but with the multiplication sign instead, using the+ -- 'Times' constructor to construct the result.+ t <- rule [ Times <@> t <# '*' <#> f+ -- A @t@ can also be an @f@ (factor).+ , id <@> f+ ]+ -- An @f@ can either be an expression in parentheses, or a variable+ -- (written 'x' in the language). Notice the use of '<@' and '<#' when not+ -- using a symbol when constructing the result of the production.+ f <- rule [ id <@ '(' <#> e <# ')'+ , Var <@ 'x'+ ]+ -- Lastly, we need to return the entry rule of the grammar.+ return e
+ examples/Ex1SimpleExprParser.hs view
@@ -0,0 +1,65 @@+-- | Generate parsers for the simple expression grammar.++-- Needed for generating parsers at compile-time.+{-# LANGUAGE TemplateHaskell #-}+module Ex1SimpleExprParser where++-- Normally you would only import one of these depending on whether you want+-- to generate parsers at compile-time or runtime, but here we will show both.+import Data.Parser.Grempa.Static+import Data.Parser.Grempa.Dynamic++-- Import the grammar+import Ex1SimpleExpr++-- | The type of this function tells us that it is a parser for a+-- language operating on lists of 'Char's returning an 'E' if the parsing+-- is successful.+parseExprStatic :: Parser Char E+-- For making static parsers, Grempa needs both the "representation" of the+-- grammar, which in this case is achieved by [|expr|], and the grammar itself,+-- which is the reason for the repetition of arguments to the function.+parseExprStatic = $(mkStaticParser expr [|expr|])++-- | @'Parser' t a@ is a synynom to @[t] -> 'Either' ('ParseError' t) a@.+-- Often the desired functionality is @[t] -> a@ where the parser will throw+-- an exception if something goes wrong. The 'parse' function does just that+-- transformation to the parser.+parseExprStaticResult :: String -> E+parseExprStaticResult = parse parseExprStatic++-- | For making dynamic parsers, no Template Haskell magic is needed.+-- A parser will be created at runtime, which can take some time for big+-- grammars, but it makes it possible to create grammars that for example+-- depend on some input.+--+-- The function mkDynamicParser takes as a first argument a tuple consisting+-- of a wrap and an unwrap function to be run on all input tokens before and+-- after parsing respectively. This can sometimes be useful when the Eq and+-- Ord instances of the token type are not what is desired in the parser, as+-- we will see in later examples.+--+-- For this grammar, we will use the idWrapper (=(id, id)) which does not wrap+-- the tokens.+parseExprDynamic :: Parser Char E+parseExprDynamic = mkDynamicParser idWrapper expr++-- | You can do the same transformation as before to the dynamically generated+-- parsers.+parseExprDynamicResult :: String -> E+parseExprDynamicResult = parse parseExprDynamic++-- | Try a parser out on some input strings.+-- Run it using for example @test 'parseExprStaticResult'.+-- Notice that the precedence levels are what we are normally used to+-- and that the parentheses are included in the result not by a separate+-- constructor, but just by the structure.+test :: (String -> E) -> [E]+test p = map p inputStrings+ where+ inputStrings =+ [ "x+x"+ , "x*x+x*x"+ , "x*(x+x)*x"+ , "x*((((x))))"+ ]
+ examples/Ex2Calculator.hs view
@@ -0,0 +1,76 @@+-- | Example 2: Parsing a list of tokens instead of a 'String' and computing +-- the desired result directly.+-- In this example it is assumed that there exists a lexer+-- that goes from @'String' -> 'CToken'@, so that an input+-- 'String' can be fed into the lexer and then into the generated+-- parser.++-- Needed for recursive do notation.+{-# LANGUAGE DoRec #-}+-- Needed for deriving 'Typeable'.+{-# LANGUAGE DeriveDataTypeable #-}+-- Needed for deriving 'Lift'.+{-# LANGUAGE TemplateHaskell #-}++module Ex2Calculator where++-- First import the Grempa grammar combinators.+import Data.Parser.Grempa.Grammar+-- We also need the 'ToPat' class to be in scope.+import Data.Parser.Grempa.Static (ToPat(..), toConstrPat)++-- The result datatype must be an instance of the 'Typeable' typeclass.+-- Fortunately, it is possible to derive an instance. Using the extension+-- above.+import Data.Typeable+import Data.Data+-- For deriving 'Lift' instances.+import Language.Haskell.TH.Lift++-- Our token datatype. The parser will operate on a list of those.+data CToken+ = Num {unNum :: Integer}+ | Plus+ | Times+ | LParen | RParen+ -- Tokens have to have instances of a number of typeclasses ('Data', 'Eq',+ -- 'Ord' and 'Show'). When making a static parser, they also have to be+ -- members of 'Typeable' and also 'Lift' for 'toConstrPat' to work.+ deriving (Data, Eq, Ord, Show, Typeable)++-- Derive a 'Lift' instance+$(deriveLift ''CToken)++-- The tokens of the language we are making a static parser for must have a+-- 'ToPat' instance, which provides a way for Grempa to convert the token+-- to a Template Haskell pattern matching. For tokens that should only be+-- compared on the constructor level, the implementation is easy, as there is+-- a function to do just that in Grempa.+instance ToPat CToken where+ toPat = toConstrPat++-- | Our grammar operates on lists of 'CTokens' and returns the 'Integer'+-- result directly, without computing a tree-shaped result.+calc :: Grammar CToken Integer+-- This is very similar to the definition of the previous example, but using+-- operators operating on 'Integer's instead of constructors for the semantic+-- actions.+calc = do+ rec+ e <- rule [ (+) <@> e <# Plus <#> t+ , id <@> t+ ]+ t <- rule [ (*) <@> t <# Times <#> f+ , id <@> f+ ]+ f <- rule [ id <@ LParen <#> e <# RParen+ , unNum <@> num+ ]+ return e+ where+ -- We are using the fact that the parser will be able to only look at the+ -- constructors when comparing different tokens if we want it to work that+ -- way, which is why we can use for example this to represent any number+ -- token.+ num = Num 0+
+ examples/Ex2CalculatorParser.hs view
@@ -0,0 +1,44 @@+-- | Generate parsers for the calculator.++-- Needed for generating parsers at compile-time.+{-# LANGUAGE TemplateHaskell #-}+module Ex2CalculatorParser where++-- Normally you would only import one of these depending on whether you want+-- to generate parsers at compile-time or runtime, but here we will show both.+import Data.Parser.Grempa.Static+import Data.Parser.Grempa.Dynamic++-- Import the grammar+import Ex2Calculator++-- Now we can use 'mkStaticParser' just like before+parseCalcStatic :: Parser CToken Integer+parseCalcStatic = $(mkStaticParser calc [|calc|])++parseCalcStaticResult :: [CToken] -> Integer+parseCalcStaticResult = parse parseCalcStatic++-- When dealing with dynamic parsers, 'ToPat' cannot be used, and we instead+-- have to wrap the tokens into something that has the desired properties.+-- Here we are wrapping them in 'constrWrapper' which will have the same result+-- as using 'toConstrPat' when making a static parser.+parseCalcDynamic :: Parser CToken Integer+parseCalcDynamic = mkDynamicParser constrWrapper calc++parseCalcDynamicResult :: [CToken] -> Integer+parseCalcDynamicResult = parse parseCalcDynamic++-- | Try a parser out on some input token strings.+-- Run it using for example @'test' 'parseCalcStaticResult'.+-- Notice that we get the 'Integer' result directly.+test :: ([CToken] -> Integer) -> [Integer]+test p = map p inputStrings+ where+ inputStrings =+ [ [Num 2, Plus, Num 3]+ , [Num 2, Times, Num 3, Plus, Num 4, Times, Num 5]+ , [Num 2, Times, LParen, Num 3, Plus, Num 4, RParen, Times, Num 5]+ , [Num 2, Times, LParen, LParen, LParen, LParen, Num 3+ , RParen, RParen, RParen, RParen]+ ]
+ examples/Ex3Fun.hs view
@@ -0,0 +1,93 @@+-- | Example 3: A grammar for a small functional language.+-- This example also includes a naive lexer.+{-# LANGUAGE DeriveDataTypeable, DoRec #-}+module Ex3Fun (fun, Def) where++import Control.Applicative+import Data.Data++import Data.Parser.Grempa.Grammar++import Ex3FunLex++-- * Result data definitions+data Def+ = Def String [Pat] Expr+ deriving (Eq, Show, Typeable)++data Expr+ = ECase Expr [Branch]+ | ELet Def Expr+ | EApp Expr Expr+ | EOp Expr String Expr+ | EVar String+ | ENum Integer+ | ECon String+ deriving (Eq, Show, Typeable)++data Branch+ = Branch Pat Expr+ deriving (Eq, Show, Typeable)++data Pat+ = PCon String [Pat]+ | PVar String+ deriving (Eq, Show, Typeable)++-- | Grammar for the language+fun :: Grammar Tok [Def]+fun = do+ rec+ def <- rule+ [Def <$> fromTok+ <@> var <#> pats0 <# Equals <#> expr]+ -- Here we can use the Grempa function 'severalInter0' meaning 0 or more+ -- 'def's interspersed with 'SemiColon's+ defs <- severalInter0 SemiColon def++ pat <- rule+ [PCon <$> fromTok+ <@> con <#> pats+ ,id <@> apat+ ]+ apat <- rule+ [flip PCon [] . fromTok <@> con+ ,PVar . fromTok <@> var+ ,paren pat+ ]+ -- @pats0@ means 0 or more @apat@s+ pats0 <- several0 apat+ -- This shows the usage of the 'cons' function, which simply creates a new+ -- rule of @apat@ followed by @pats0@, combined with '(:)'.+ pats <- apat `cons` pats0++ expr <- rule+ [ECase <@ Case <#> expr <# Of <# LCurl <#> casebrs <# RCurl+ ,ELet <@ Let <#> def <# In <#> expr+ ,id <@> expr1+ ]+ expr1 <- rule+ -- All binary operators are parsed as being left-associative+ -- A post-processor could be used to change this when fixities+ -- and precedence levels of all operators are are known+ [flip (flip EOp . fromTok)+ <@> expr1 <#> op <#> expr2+ ,id <@> expr2+ ]+ expr2 <- rule+ [EApp <@> expr2 <#> expr3+ ,id <@> expr3+ ]+ expr3 <- rule+ [EVar . fromTok <@> var+ ,ENum . fromNum <@> num+ ,ECon . fromTok <@> con+ ,paren expr+ ]++ casebr <- rule [Branch <@> pat <# RightArrow <#> expr]+ casebrs <- severalInter0 SemiColon casebr++ return defs+ where+ paren x = id <@ LParen <#> x <# RParen
+ examples/Ex3FunLex.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+-- A lexer for Example 3. This is a really naive lexer and should not be used+-- in production. It is merely for showing how the parser works.+module Ex3FunLex+ ( Tok(..), lexToks+ , var, con, op, num+ ) where++import Data.Char+import Data.Data+import Language.Haskell.TH.Lift+import Data.Parser.Grempa.Static++-- | Token datatype+data Tok+ = Var {fromTok :: String}+ | Con {fromTok :: String}+ | Op {fromTok :: String}+ | Data+ | Case | Of+ | Let | In+ | Num {fromNum :: Integer}+ | Equals+ | RightArrow+ | LParen | RParen+ | LCurl | RCurl+ | SemiColon+ | Bar+ deriving (Eq, Ord, Data, Typeable, Show, Read)++$(deriveLift ''Tok)+instance ToPat Tok where toPat = toConstrPat++-- * Shorthands for constructors applied to something+-- (could be anything since the ToPat instance creates wildcard patterns for+-- everything save for the constructor)+var, con, op, num :: Tok+var = Var ""+con = Con ""+op = Op ""+num = Num 0++-- | Do the lexing!+lexToks :: String -> [Tok]+lexToks [] = []+lexToks ('d':'a':'t':'a':as) | testHead (not . isId) as = Data : lexToks as+lexToks ('c':'a':'s':'e':as) | testHead (not . isId) as = Case : lexToks as+lexToks ('o':'f' :as) | testHead (not . isId) as = Of : lexToks as+lexToks ('l':'e':'t' :as) | testHead (not . isId) as = Let : lexToks as+lexToks ('i':'n' :as) | testHead (not . isId) as = In : lexToks as+lexToks ('=' :as) | testHead (not . isSym) as = Equals : lexToks as+lexToks ('-':'>' :as) | testHead (not . isSym) as = RightArrow : lexToks as+lexToks ('|' :as) | testHead (not . isSym) as = RParen : lexToks as+lexToks ('(' :as) = LParen : lexToks as+lexToks (')' :as) = RParen : lexToks as+lexToks ('{' :as) = LCurl : lexToks as+lexToks ('}' :as) = RCurl : lexToks as+lexToks (';' :as) = SemiColon : lexToks as+lexToks as@(a:rest)+ | isLower a = go Var isId as+ | isUpper a = go Con isId as+ | isDigit a = go (Num . read) isDigit as+ | isSym a = go Op isSym as+ | otherwise = lexToks rest++testHead :: (Char -> Bool) -> String -> Bool+testHead _ "" = True+testHead f (a:_) = f a++isId :: Char -> Bool+isId c = isAlphaNum c || c == '_' || c == '\''++isSym :: Char -> Bool+isSym '(' = False+isSym ')' = False+isSym c = isPunctuation c || isSymbol c++go :: (String -> Tok) -> (Char -> Bool) -> String -> [Tok]+go c p xs = let (v, rest) = span p xs in c v : lexToks rest
+ examples/Ex3FunParser.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+module Ex3FunParser where++import Data.Parser.Grempa.Static+import Data.Parser.Grempa.Dynamic++-- Import the grammar.+import Ex3Fun+-- We also need the token datatype in scope or Template Haskell will complain.+import Ex3FunLex++-- | Make a static parser+parseFunStatic :: Parser Tok [Def]+parseFunStatic = $(mkStaticParser fun [|fun|])++-- | Make a dynamic parser using 'constrWrapper'.+parseFunDynamic :: Parser Tok [Def]+parseFunDynamic = mkDynamicParser constrWrapper fun++-- | Combine the lexer with a parser+lexAndParse :: String -> [Def]+lexAndParse = parse parseFunStatic . lexToks++-- | Try it out!+test :: [[Def]]+test = map lexAndParse inputString+ where+ inputString = [ "f (X x) = Y x; g x y z = x * y + z"+ , "fromJust m = case m of {Just x -> x; Nothing -> undefined}"+ , "foldr f s (Cons x xs) = f x $ foldr f s xs; foldr f s Nil = s"+ ]
+ examples/Ex4Test.hs view
@@ -0,0 +1,26 @@+-- | Use QuickCheck to test your parsers.+module Ex4Test where++-- The Grempa library has to be built with the test flag to be able to use this.+import Data.Parser.Grempa.Test+import Test.QuickCheck++-- Import the different parsers and grammars+import Ex1SimpleExpr(expr)+import Ex1SimpleExprParser(parseExprStatic)++import Ex2Calculator(calc)+import Ex2CalculatorParser(parseCalcStatic)++import Ex3Fun(fun)+import Ex3FunParser(parseFunStatic)++-- | Running 'quickCheck' on these different tests will generate random+-- inputs from the grammars and the expected output, and compare the parser's+-- output with that. This is useful to see that the parser covers all of the+-- defined language (you should get conflicts if it does not, but it feels+-- good to get an assurance).+testEx1, testEx2, testEx3 :: Property+testEx1 = prop_parser parseExprStatic expr+testEx2 = prop_parser parseCalcStatic calc+testEx3 = prop_parser parseFunStatic fun