Grempa 0.1.0 → 0.1.1
raw patch · 19 files changed
+459/−213 lines, 19 filesdep ~QuickCheckdep ~monads-fd
Dependency ranges changed: QuickCheck, monads-fd
Files
- Data/Parser/Grempa/Aux/MultiMap.hs +13/−2
- Data/Parser/Grempa/Grammar.hs +3/−0
- Data/Parser/Grempa/Grammar/Levels.hs +47/−0
- Data/Parser/Grempa/Grammar/Typed.hs +2/−2
- Data/Parser/Grempa/Grammar/Untyped.hs +69/−26
- Data/Parser/Grempa/Parser/Conflict.hs +1/−1
- Data/Parser/Grempa/Parser/Item.hs +52/−17
- Data/Parser/Grempa/Parser/LALR.hs +23/−35
- Data/Parser/Grempa/Parser/SLR.hs +0/−65
- Grempa.cabal +9/−4
- README +2/−2
- examples/Ex2Calculator.hs +8/−10
- examples/Ex3Fun.hs +23/−23
- examples/Ex4StateA.hs +51/−0
- examples/Ex4StateB.hs +59/−0
- examples/Ex4StateLex.hs +46/−0
- examples/Ex4StateParser.hs +26/−0
- examples/Ex4Test.hs +0/−26
- examples/Ex5Test.hs +25/−0
Data/Parser/Grempa/Aux/MultiMap.hs view
@@ -5,10 +5,12 @@ , lookup , insert , inserts+ , delete , union , unions , fromList , M.empty+ , toList ) where import qualified Data.Map as M@@ -24,11 +26,17 @@ 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+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+inserts k v m = M.insertWith S.union k v m +delete :: (Ord a, Ord k) => k -> a -> MultiMap k a -> MultiMap k a+delete k v m = M.update aux k m+ where aux ss = let ss' = S.delete v ss in if S.null ss'+ then Nothing+ else Just ss'+ 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 @@ -37,3 +45,6 @@ fromList :: (Ord a, Ord k) => [(k, a)] -> MultiMap k a fromList = foldl (flip $ uncurry insert) M.empty++toList :: (Ord a, Ord k) => MultiMap k a -> [(k, Set a)]+toList = M.toList
Data/Parser/Grempa/Grammar.hs view
@@ -38,11 +38,14 @@ {-# LANGUAGE DoRec, TypeFamilies #-} module Data.Parser.Grempa.Grammar ( module Data.Parser.Grempa.Grammar.Typed+ , module Data.Parser.Grempa.Grammar.Levels , several0, several, severalInter0, severalInter, cons ) where+ import Data.Typeable import Data.Parser.Grempa.Grammar.Typed (Grammar, rule, ToSym(..), (<#>), (<#), (<@>), (<@), epsilon)+import Data.Parser.Grempa.Grammar.Levels -- | Create a new rule which consists of 0 or more of the argument symbol. -- Example: @several0 x@ matches @x x ... x@
+ Data/Parser/Grempa/Grammar/Levels.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DoRec #-}+module Data.Parser.Grempa.Grammar.Levels+ ( levels+ , lrule+ ) where++import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Fix+import Data.Typeable++import Data.Parser.Grempa.Grammar.Typed++newtype ReverseT m a = ReverseT { runReverseT :: m a }++instance MonadFix m => Monad (ReverseT m) where+ return = ReverseT . return+ ReverseT m >>= f =+ ReverseT $ do+ rec+ b <- runReverseT (f a)+ a <- m+ return b++instance MonadTrans ReverseT where+ lift = ReverseT++instance MonadFix m => MonadFix (ReverseT m) where+ mfix f = ReverseT $ mfix (runReverseT . f)++type RStateT s m a = ReverseT (StateT s m) a++levels :: Monad m => RStateT (Maybe a) m r -> m r+levels = flip evalStateT Nothing . runReverseT++lrule :: (Typeable a, Typeable t)+ => Rule t a+ -> RStateT (Maybe (RId t a)) (GrammarState t) (RId t a)+lrule r = do+ rec+ lift $ put (Just rid)+ rid <- lift $ lift $ rule $ case mnext of+ Just next -> (id <@> next) : r+ Nothing -> r+ mnext <- lift get+ return rid+
Data/Parser/Grempa/Grammar/Typed.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_HADDOCK hide #-} module Data.Parser.Grempa.Grammar.Typed ( Grammar- , Prod(..), Symbol(..), RId(..)+ , Rule, Prod(..), Symbol(..), RId(..) , GrammarState , rule , evalGrammar@@ -47,7 +47,7 @@ -- 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 GrammarState t = State (RuleIDs t) type Grammar t a = GrammarState t (RId t a) -- | Get the result from a Grammar computation
Data/Parser/Grempa/Grammar/Untyped.hs view
@@ -3,7 +3,7 @@ ( Rule, Prod, Symbol(..), RId(..) , unType , rules, terminals, nonTerminals- , first, firstProd, follow+ , firstProd, follow )where import qualified Control.Arrow as A@@ -15,6 +15,8 @@ import qualified Data.Set as S import Data.Parser.Grempa.Aux.Aux+import qualified Data.Parser.Grempa.Aux.MultiMap as MM+import Data.Parser.Grempa.Aux.MultiMap(MultiMap) import Data.Parser.Grempa.Parser.Table import Data.Parser.Grempa.Grammar.Token import qualified Data.Parser.Grempa.Grammar.Typed as T@@ -103,33 +105,72 @@ 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'+-- | Datatype used in computing the first set+data RecETok s+ = RETok {unRETok :: ETok s}+ | IfEpsilon (RId s) (Prod s)+ | RRule (RId s)+ deriving (Eq, Ord) ---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+type First s a = State (MultiMap (RId s) (RecETok s)) a --- | Get the first tokens of a production+-- | Get the first tokens that a symbol eats+-- first :: Token s => Symbol s -> Set (ETok s)+-- first s = firstProd [s]+ firstProd :: Token s => Prod s -> Set (ETok s)-firstProd = evalDone . firstProd'+firstProd = flip evalState MM.empty . 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+firstProd' :: Token s => Prod s -> First s (Set (ETok s))+firstProd' as = do+ go (RId (-1) undefined) as+ fixf+ results <$> gets (MM.lookup (RId (-1) undefined))+ where+ go :: Token s => RId s -> Prod s -> First s ()+ go rid [] = modify $ MM.insert rid (RETok Epsilon)+ go rid (STerm s:_) = modify $ MM.insert rid (RETok (ETok s))+ go rid (SRule rid'@(RId _ ps):xs) = do+ modify $ MM.insert rid (RRule rid')+ ss <- gets $ MM.lookup rid'+ when (S.null ss) $ mapM_ (go rid') ps+ modify $ MM.insert rid (IfEpsilon rid' xs) + f :: Token s => RId s -> RecETok s -> First s ()+ f rid rt@(IfEpsilon rid' xs) = do+ ss <- gets (MM.lookup rid')+ when (S.member (RETok Epsilon) ss) $ do+ modify $ MM.delete rid rt+ go rid xs+ f rid rt@(RRule rid') = do+ ss <- gets (MM.lookup rid')+ when (clean ss) $ do+ modify $ MM.delete rid rt+ modify $ MM.inserts rid (S.filter isRETok ss)+ f _ _ = return ()++ clean :: Set (RecETok s) -> Bool+ clean = S.fold ((&&) . isRETok) True++ isRETok :: RecETok s -> Bool+ isRETok (RETok _) = True+ isRETok _ = False++ fs :: Token s => First s ()+ fs = do+ ss <- get+ sequence_ [f rid rt | (rid, rts) <- MM.toList ss, rt <- S.toList rts]++ results :: Token s => Set (RecETok s) -> Set (ETok s)+ results = S.map unRETok . S.filter isRETok++ fixf :: Token s => First s ()+ fixf = do+ state <- get+ fs+ state' <- get+ when (state /= state') fixf+ -- | 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)@@ -146,9 +187,11 @@ 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+ | b == SRule rid = S.union rest+ <$> liftM2 S.union (followProd beta a)+ (if Epsilon `S.member` firstbeta+ then follow' a startrid rids+ else return S.empty) | otherwise = followProd beta a where firstbeta = firstProd beta
Data/Parser/Grempa/Parser/Conflict.hs view
@@ -38,7 +38,7 @@ ++ "), between " ++ intercalate " and " (map go confs) where go cs = "[" ++ intercalate "," (map go' cs) ++ "]"- go' (t, a) = "On token " ++ show (unTok t) ++ " " ++ showAction a+ go' (t, a) = "On token " ++ tokToString t ++ " " ++ showAction a showAction (Shift s) = "shift state " ++ show s showAction (Reduce r p _ _) = "reduce (rule " ++ show r ++ ", production " ++ show p ++ ")" showAction Accept = "accept"
Data/Parser/Grempa/Parser/Item.hs view
@@ -3,10 +3,11 @@ ( It(..), getItProd, isKernelIt , kernel , nextSymbol- , goto , nextItPos , Gen, GenData(..), runGen, gen , askItemSet+ , precomputeGotos+ , askGoto ) where import Control.Applicative@@ -38,6 +39,7 @@ isKernelIt st it = pos > 0 || (itRId it == st && pos == 0) where pos = getItPos it +-- | Get the kernel of an item set kernel :: It i s => RId s -> Set (i s) -> Set (i s) kernel st = S.filter $ isKernelIt st @@ -69,6 +71,7 @@ itemSets' c = (c `S.union` gs, gs) where gs = S.fromList [goto i x | i <- S.toList c, x <- symbols] +-- | Data environment for parser generation data GenData i s = GenData { gItemSets :: [(Set (i s), StateI)] , gItemSetIndex :: Map (Set (i s)) StateI@@ -78,31 +81,63 @@ , gSymbols :: [Symbol s] , gStartState :: Int , gStartRule :: RId s+ , gGotos :: Map (StateI, Symbol s) StateI } deriving Show type Gen i s = Reader (GenData i s) runGen :: Gen i s a -> GenData i s -> a runGen = runReader +-- | Create an initial parser generator data structure gen :: (It i s, Token s) => RId s -> GenData i s-gen g = GenData is ix rs ts nt sys ss g+gen g = GenData+ { gItemSets = items+ , gItemSetIndex = itemIx+ , gRules = ruless+ , gTerminals = terms+ , gNonTerminals = nonTerms+ , gSymbols = syms+ , gStartState = snd $ fromMaybe (error "gen: maybe")+ $ find (S.member (startItem g) . fst) items+ , gStartRule = g+ , gGotos = precomputeGotos items itemIx syms+ }+ where items = zip (S.toList $ itemSets g ruless) [0..]+ itemIx = M.fromList items+ ruless = rules g+ terms = terminals ruless+ nonTerms = nonTerminals ruless+ syms = terms ++ nonTerms++-- | Calculate the goto function for all inputs and put it in a map+precomputeGotos :: (It i s, Token s)+ => [(Set (i s), StateI)] -> Map (Set (i s)) StateI -> [Symbol s]+ -> Map (StateI, Symbol s) StateI+precomputeGotos iss isi syms = M.fromList+ [((ii, sym), st) | (is, ii) <- iss+ , sym <- syms+ , Just st <- [findState $ goto is sym]] 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+ findState = lookupItemSet iss isi +lookupItemSet :: (It i s, Token s)+ => [(Set (i s), StateI)] -> Map (Set (i s)) StateI+ -> Set (i s)+ -> Maybe StateI+lookupItemSet iss isi x+ | S.null x = Nothing+ | otherwise = case M.lookup x isi of+ Nothing -> snd <$> listToMaybe (filter (S.isSubsetOf x . fst) iss)+ y -> y++-- | Get what item set index an item set corresponds to 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)+ iss <- asks gItemSets+ isi <- asks gItemSetIndex+ return $ lookupItemSet iss isi x++-- | Lookup a precomputed goto value+askGoto :: (It i s, Token s) => StateI -> Symbol s -> Gen i s (Maybe StateI)+askGoto st sym = M.lookup (st, sym) <$> asks gGotos
Data/Parser/Grempa/Parser/LALR.hs view
@@ -34,7 +34,6 @@ "," ++ show po ++ "," ++ show la ++ ")\n" - instance Token s => It Item s where itRId = itemRId itProd = itemProd@@ -43,7 +42,6 @@ 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'@@ -78,26 +76,23 @@ 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+lookaheads istate k x = do+ askGoto istate x >>=+ maybe (return MM.empty) (\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+ $ 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)+ = [if itemLA b /= Tok Nothing+ then ((jstate, nextItPos $ fromLALR b), Spont $ itemLA b)+ else ((jstate, nextItPos $ fromLALR b), PropFrom istate a) | b <- S.toList js , nextSymbol b == Tok x] where js = closure $ S.singleton $ fromSLR a (Tok Nothing)@@ -129,7 +124,8 @@ 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+ las <- zipWithM (\(_,n) (k,_) -> MM.unions+ <$> mapM (lookaheads n k) syms) iss kss let tab = MM.unions las return [ let newi = [ evalDone $ toIts it <$> findLookaheads tab n it@@ -142,8 +138,10 @@ slrGenToLalrGen :: Token s => GenData SLR.Item (Maybe s) -> GenData Item (Maybe s) slrGenToLalrGen g = let newits = runGen lalrItems g+ newix = M.fromList newits in g { gItemSets = newits- , gItemSetIndex = M.fromList newits+ , gItemSetIndex = newix+ , gGotos = precomputeGotos newits newix (gSymbols g) } -- | Create LALR parsing tables from a starting rule of a grammar (augmented) lalr :: Token s => RId s -> (ActionTable s, GotoTable s, Int)@@ -152,21 +150,16 @@ initg = slrGenToLalrGen initSlr cs = gItemSets initg as = [runGen (actions i) initg | i <- cs]- gs = concat [runGen (gotos 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+ => StateI -> Gen Item (Maybe s) [((StateI, RuleI), StateI)]+gotos 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]+ catMaybes <$> sequence+ [fmap ((i,ai),) <$> askGoto i a | a@(SRule (RId ai _)) <- nt] -- | Create action table actions :: Token s@@ -175,17 +168,12 @@ 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) [])]+ Tok a@(STerm (Just s)) ->+ maybe [] ((:[]) . (Tok s,) . Shift) <$> askGoto i a+ EOF | rid /= start -> return+ [ ( fromJust <$> itemLA item+ , Reduce ri (itProd item)+ (length $ getItProd item) [])] | itemLA item == EOF -> return [(EOF, Accept)] _ -> return [] tab <- concat <$> sequence
Data/Parser/Grempa/Parser/SLR.hs view
@@ -1,18 +1,12 @@ {-# 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 @@ -49,62 +43,3 @@ 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
Grempa.cabal view
@@ -1,5 +1,5 @@ Name: Grempa-Version: 0.1.0+Version: 0.1.1 Synopsis: Embedded grammar DSL and LALR parser generator Description: A library for expressing programming language grammars in a form similar@@ -26,7 +26,11 @@ , examples/Ex3Fun.hs , examples/Ex3FunLex.hs , examples/Ex3FunParser.hs- , examples/Ex4Test.hs+ , examples/Ex4StateA.hs+ , examples/Ex4StateB.hs+ , examples/Ex4StateLex.hs+ , examples/Ex4StateParser.hs+ , examples/Ex5Test.hs Cabal-version: >= 1.6 Flag test Description:@@ -37,7 +41,7 @@ Build-depends: array == 0.3.* , base == 4.2.* , containers == 0.3.*- , monads-fd == 0.1.*+ , monads-fd == 0.2.* , template-haskell == 2.4.* , th-lift == 0.5.* Exposed-modules: Data.Parser.Grempa.Grammar@@ -45,6 +49,7 @@ , Data.Parser.Grempa.Dynamic Other-modules: Data.Parser.Grempa.Aux.Aux , Data.Parser.Grempa.Aux.MultiMap+ , Data.Parser.Grempa.Grammar.Levels , Data.Parser.Grempa.Grammar.Token , Data.Parser.Grempa.Grammar.Typed , Data.Parser.Grempa.Grammar.Untyped@@ -59,5 +64,5 @@ , Data.Parser.Grempa.Parser.Table GHC-Options: -Wall if flag(test)- Build-Depends: QuickCheck == 2.2.*+ Build-Depends: QuickCheck == 2.4.* Exposed-modules: Data.Parser.Grempa.Test
README view
@@ -21,8 +21,8 @@ * Examples - The examples directory contains examples of varying complexity and serves- as an introduction to the usage of the library.+ The examples directory contains examples of varying complexity which can be+ used as an introduction to the usage of the library. The examples are numbered, which serves as a suggested reading order.
examples/Ex2Calculator.hs view
@@ -55,17 +55,15 @@ -- 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+-- Here we are using 'levels' and 'lrule's which means that the rules will+-- be linked together automatically with identity rules.+calc = levels $ do rec- e <- rule [ (+) <@> e <# Plus <#> t- , id <@> t- ]- t <- rule [ (*) <@> t <# Times <#> f- , id <@> f- ]- f <- rule [ id <@ LParen <#> e <# RParen- , unNum <@> num- ]+ e <- lrule [ (+) <@> e <# Plus <#> t ]+ t <- lrule [ (*) <@> t <# Times <#> f ]+ f <- lrule [ 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
examples/Ex3Fun.hs view
@@ -61,29 +61,29 @@ -- 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- ]+ expr <- levels $ do+ rec+ expr <- lrule+ [ECase <@ Case <#> expr <# Of <# LCurl <#> casebrs <# RCurl+ ,ELet <@ Let <#> def <# In <#> expr+ ]+ expr1 <- lrule+ -- 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+ ]+ expr2 <- lrule+ [EApp <@> expr2 <#> expr3+ ]+ expr3 <- lrule+ [EVar . fromTok <@> var+ ,ENum . fromNum <@> num+ ,ECon . fromTok <@> con+ ,paren expr+ ]+ return expr casebr <- rule [Branch <@> pat <# RightArrow <#> expr] casebrs <- severalInter0 SemiColon casebr
+ examples/Ex4StateA.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving, DeriveDataTypeable, DoRec #-}+module Ex4StateA (state, Expr, St, evalSt) where++import Control.Applicative+import Control.Monad.State+import Data.Data+import Data.List+import Data.Maybe++import Data.Parser.Grempa.Grammar++import Ex4StateLex++-- * Result data definitions+data Expr+ = EApp Expr Expr+ | EVar Integer+ | ELam Expr+ deriving (Eq, Show, Typeable)++type St a = [String] -> a+evalSt f = f []++-- | Grammar for the language+state :: Grammar Tok Expr+state = do+ rec+ var <- rule [ fromTok <@> Var ""]+ term1 <- levels $ do+ rec+ -- Here the rules return functions of type 'St'.+ t1 <- lrule [ mkLam <@ Lambda <#> var <# RightArrow <#> t1 ]+ t2 <- lrule [ mkApp <@> t2 <#> t3 ]+ t3 <- lrule [ mkVar <@> var+ , id <@ LParen <#> t1 <# RParen+ ]+ return t1+ -- Here we apply the final 'St' function to get the real result.+ term <- rule [ evalSt <@> term1 ]+ return term+ where+ mkLam :: String -> St Expr -> St Expr+ mkLam v e st = ELam (e (v : st))++ mkApp :: St Expr -> St Expr -> St Expr+ mkApp a b st = EApp (a st) (b st)++ mkVar :: String -> St Expr+ mkVar v vars = EVar $ snd+ $ fromMaybe undefined+ $ find ((== v) . fst) (zip vars [0..])
+ examples/Ex4StateB.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DoRec #-}+module Ex4StateB (state, Expr, St, evalSt) where++import Control.Applicative+import Control.Monad.Reader+import Data.Data+import Data.List+import Data.Maybe++import Data.Parser.Grempa.Grammar++import Ex4StateLex++-- * Result data definitions+data Expr+ = EApp Expr Expr+ | EVar Integer+ | ELam Expr+ deriving (Eq, Show, Typeable)++-- | The parsing state is just a wrapper around the Reader monad to make it+-- possible to derive Typeable which is needed. We could also use a State+-- monad but that is not necessary in this example.+newtype St a = St { unSt :: Reader [String] a }+ deriving (Typeable, Applicative, Functor, Monad, MonadReader [String])++evalSt = flip runReader [] . unSt++-- | Grammar for the language+state :: Grammar Tok Expr+state = do+ rec+ var <- rule [ fromTok <@> Var ""]+ term1 <- levels $ do+ rec+ -- Now the rules return 'St' computations instead of their data result.+ t1 <- lrule [ mkLam <@ Lambda <#> var <# RightArrow <#> t1 ]+ t2 <- lrule [ mkApp <@> t2 <#> t3 ]+ t3 <- lrule [ mkVar <@> var+ , id <@ LParen <#> t1 <# RParen+ ]+ return t1+ -- Here we evaluate the final 'St' computation to get the result.+ term <- rule [ evalSt <@> term1 ]+ return term+ where+ mkLam :: String -> St Expr -> St Expr+ mkLam v e = ELam <$> local (v :) e++ mkApp :: St Expr -> St Expr -> St Expr+ mkApp a b = EApp <$> a <*> b++ mkVar :: String -> St Expr+ mkVar v = do+ vars <- ask+ return $ EVar+ $ snd+ $ fromMaybe undefined+ $ find ((== v) . fst) (zip vars [0..])
+ examples/Ex4StateLex.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+module Ex4StateLex+ ( Tok(..), lexToks+ ) where++import Data.Char+import Data.Data+import Language.Haskell.TH.Lift+import Data.Parser.Grempa.Static++-- | Token datatype+data Tok+ = Var {fromTok :: String}+ | Lambda+ | RightArrow+ | LParen | RParen+ deriving (Eq, Ord, Data, Typeable, Show, Read)++$(deriveLift ''Tok)+instance ToPat Tok where toPat = toConstrPat++-- | Do the lexing!+lexToks :: String -> [Tok]+lexToks [] = []+lexToks ('-':'>' :as) | testHead (not . isSym) as = RightArrow : lexToks as+lexToks ('\\' :as) = Lambda : lexToks as+lexToks ('(' :as) = LParen : lexToks as+lexToks (')' :as) = RParen : lexToks as+lexToks as@(a:rest)+ | isLower a = go Var isId as+ | otherwise = lexToks rest++go :: (String -> Tok) -> (Char -> Bool) -> String -> [Tok]+go c p xs = let (v, rest) = span p xs in c v : 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
+ examples/Ex4StateParser.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+module Ex4StateParser where++import Data.Parser.Grempa.Static+import Data.Parser.Grempa.Dynamic+import Control.Monad.State++-- Import the grammar.+import Ex4StateB+-- We also need the token datatype in scope or Template Haskell will complain.+import Ex4StateLex++parseStateStatic :: Parser Tok Expr+parseStateStatic = $(mkStaticParser state [|state|])++-- | Combine the lexer with a parser+lexAndParse :: String -> Expr+lexAndParse = parse parseStateStatic . lexToks++-- | Try it out!+test :: [Expr]+test = map lexAndParse inputString+ where+ inputString = [ "\\x -> (\\y -> y) x"+ , "\\x -> \\y -> \\z -> x y z"+ ]
− examples/Ex4Test.hs
@@ -1,26 +0,0 @@--- | 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
+ examples/Ex5Test.hs view
@@ -0,0 +1,25 @@+-- | 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 = prop_parser parseExprStatic expr+testEx2 = prop_parser parseCalcStatic calc+testEx3 = prop_parser parseFunStatic fun