gll (empty) → 0.1.0.0
raw patch · 8 files changed
+957/−0 lines, 8 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- gll.cabal +28/−0
- src/GLL/Combinators/Combinators.hs +145/−0
- src/GLL/Common.hs +4/−0
- src/GLL/Machines/RGLL.lhs +382/−0
- src/GLL/Types/Abstract.hs +39/−0
- src/GLL/Types/Grammar.hs +327/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, L. Thomas van Binsbergen++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 L. Thomas van Binsbergen 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gll.cabal view
@@ -0,0 +1,28 @@+-- Initial haskell-gll.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: gll+version: 0.1.0.0+synopsis: GLL parser with simple combinator interface +license: BSD3+license-file: LICENSE+author: L. Thomas van Binsbergen+maintainer: ltvanbinsbergen@acm.org+category: Compilers+build-type: Simple +cabal-version: >=1.8+tested-with: GHC == 7.6.3++library+ hs-source-dirs : src+ build-depends : base >=4.5 && <= 4.6.0.1+ , containers >= 0.4+ , array+ exposed-modules : GLL.Combinators.Combinators+ other-modules : GLL.Types.Abstract+ , GLL.Types.Grammar+ , GLL.Machines.RGLL+ , GLL.Common++
+ src/GLL/Combinators/Combinators.hs view
@@ -0,0 +1,145 @@+module GLL.Combinators.Combinators (+ parse,+ parseString,+ char,+ epsilon,+ (<$>),+ (<$),+ (<*>),+ (<*),+ (<::=>)+ ) where++import GLL.Common+import GLL.Types.Grammar hiding (epsilon)+import GLL.Types.Abstract+import GLL.Machines.RGLL (gllSPPF, pNodeLookup)++import Control.Monad+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Set as S++type SymbVisit1 b = Symbol +type SymbVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]+type SymbVisit3 b = Int -> ParseContext -> SPPF -> Int -> Int -> [b]++type IMVisit1 b = [Symbol] +type IMVisit2 b = M.Map Nt [Alt] -> M.Map Nt [Alt]+type IMVisit3 b = Int -> ParseContext -> SPPF -> (Alt,Int) -> Int -> Int -> [b]++type ParseContext = IM.IntMap (IM.IntMap (S.Set Nt))++type SymbParser b = (SymbVisit1 b,SymbVisit2 b, SymbVisit3 b)+type IMParser b = (IMVisit1 b, IMVisit2 b, IMVisit3 b)++parseString :: (Show a) => SymbParser a -> String -> [a]+parseString p = parse p . map Char++parse :: (Show a) => SymbParser a -> [Token] -> [a]+parse (vpa1,vpa2,vpa3) input = + let snode = (start, 0, m)+ m = length input+ start = vpa1+ rules = vpa2 M.empty+ as = vpa3 (length input) IM.empty sppf 0 m+ grammar = case start of+ Nt x -> Grammar x [] [ Rule x alts [] | (x, alts) <- M.assocs rules ]+ Term t -> Grammar "S" [] [Rule "S" [Alt "S" [start]] []]+ Error _ _ -> error "can not parse error"+ sppf = gllSPPF grammar input+ in as ++inParseContext :: ParseContext -> (Symbol, Int, Int) -> Bool+inParseContext ctx (Nt x, l, r) = maybe False inner $ IM.lookup l ctx+ where inner = maybe False (S.member x) . IM.lookup r++toParseContext :: ParseContext -> (Nt, Int, Int) -> ParseContext+toParseContext ctx (x, l, r) = IM.alter inner l ctx+ where inner mm = case mm of + Nothing -> Just $ singleRX+ Just m -> Just $ IM.insertWith (S.union) r singleX m+ singleRX = IM.singleton r singleX+ singleX = S.singleton x++-- TODO take ParseContext into account while memoising?+memoParser :: SymbParser a -> SymbParser a+memoParser (v1,v2,v3) = (v1,v2,v3')+ where v3' m pctx sppf l r = (table IM.! l) IM.! r+ where table = IM.fromAscList + [ (l', rMap) | l' <- [0..m]+ , let rMap = IM.fromAscList [ (r',v) | r' <- [0..m]+ , let v = v3 m pctx sppf l' r' ]]++mkParser :: String -> [IMParser a] -> SymbParser a +mkParser x altPs = + let vas1 = [ va1 | va1 <- map (\(f,_,_) -> f) altPs ]+ alts = map (Alt x) vas1 + in (Nt x+ ,\rules ->+ if x `M.member` rules + then rules + else foldr ($) (M.insert x alts rules) $ (map (\(_,s,_) -> s) altPs)+ ,\m ctx sppf l r -> + let ctx' = ctx `toParseContext` (x,l,r)+ vas2 = [ va3 m ctx' sppf (alt,length rhs) l r + | (alt@(Alt _ rhs), va3) <- zip alts (map (\(_,_,t) -> t) altPs) ]+ in if ctx `inParseContext` (Nt x, l, r) + then []+ else concat vas2+ )+infix 5 <::=>+(<::=>) = mkParser++infixl 4 <*>+(<*>) :: IMParser (a -> b) -> SymbParser a -> IMParser b+(vimp1,vimp2,vimp3) <*> (vpa1,vpa2,vpa3) =+ (vimp1++[vpa1]+ ,\rules ->+ let rules1 = vpa2 rules+ rules2 = vimp2 rules1+ in rules2+ ,\m ctx sppf (alt@(Alt x rhs),j) l r ->+ let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)+ in [ a2b a | k <- ks, a <- vpa3 m ctx sppf k r, a2b <- vimp3 m ctx sppf (alt,j-1) l k ]+ )++infixl 4 <*+(<*) :: IMParser b -> SymbParser a -> IMParser b+(vimp1,vimp2,vimp3) <* (vpa1,vpa2,vpa3) =+ (vimp1++[vpa1]+ ,\rules ->+ let rules1 = vpa2 rules+ rules2 = vimp2 rules1+ in rules2+ ,\m ctx sppf (alt@(Alt x rhs),j) l r ->+ let ks = maybe [] id $ sppf `pNodeLookup` ((alt,j), l, r)+ in [ b | k <- ks, a <- vpa3 m ctx sppf k r, b <- vimp3 m ctx sppf (alt,j-1) l k ]+ )++infixl 4 <$>+(<$>) :: (a -> b) -> SymbParser a -> IMParser b+f <$> (vpa1,vpa2,vpa3) =+ ([vpa1]+ ,\rules -> + vpa2 rules+ ,\m ctx sppf (alt,j) l r ->+ let a = vpa3 m ctx sppf l r+ in maybe [] (const (map f a)) $ sppf `pNodeLookup` ((alt,1),l,r)+ )+infixl 4 <$+(<$) :: b -> SymbParser a -> IMParser b+f <$ (vpa1,vpa2,vpa3) =+ ([vpa1]+ ,\rules -> + vpa2 rules+ ,\m ctx sppf (alt,j) l r ->+ let a = vpa3 m ctx sppf l r+ in maybe [] (const (map (const f) a)) $ sppf `pNodeLookup` ((alt,1),l,r)+ )++char :: Char -> SymbParser Char+char c = (charT c, id,\_ _ _ _ _ -> [c]) ++epsilon :: SymbParser ()+epsilon = (Term Epsilon, id ,\_ _ _ _ _ -> [()])
+ src/GLL/Common.hs view
@@ -0,0 +1,4 @@+module GLL.Common where++type Nt = String+type Pid = String
+ src/GLL/Machines/RGLL.lhs view
@@ -0,0 +1,382 @@++%if false+\begin{code}+module GLL.Machines.RGLL (+ Slot(..)+ , Alt(..)+ , Symbol(..)+ , PrL+ , NtL+ , parse+ , gllSPPF+ , charS+ , charT+ , nT+ , epsilon+ , pNodeLookup+ ) where++import Data.Foldable hiding (forM_, toList)+import Prelude hiding (lookup, foldr, fmap, foldl, elem, sum)+import Control.Monad+import Control.Applicative hiding (empty)+import Data.Map (Map(..), empty, insertWith, (!), toList, lookup)+import Data.Set (member, Set(..))+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Array as Array+import qualified Data.Set as S+import qualified Data.IntSet as IS++import GLL.Common+import GLL.Types.Abstract +import GLL.Types.Grammar++\end{code}+%endif++\begin{code}+type LhsState = (Nt, Int)+type RhsState = (Slot, Int, Int)+\end{code}+%if false+\begin{code}+type Context = (SPPF, Rcal, Ucal, GSS, Pcal)+\end{code}+%endif+\begin{spec}+data Alt = Alt Nt [Symbol]+data Slot = Slot Nt [Symbol] [Symbol]+\end{spec}+\begin{code}+type Rcal = [(RhsState, SPPFNode)] +type Rcal' = Set (Int,Int,Slot,SPPFNode)+type Ucal = IM.IntMap (IM.IntMap (S.Set Slot))+type GSS = IM.IntMap (M.Map Nt [GSSEdge]) -- can be set? TODO+type Pcal = IM.IntMap (M.Map Nt [Int]) -- can be set? TODO++type GSSEdge = (SlotL, SPPFNode)+type GSSNode = (Nt, Int)+data GSlot = GSlot Slot+ | U0 + deriving (Ord, Eq) ++data ASM a = ASM (Context -> (a, Context))++\end{code}++\begin{code}+addState :: SPPFNode -> RhsState -> ASM ()+getState :: ASM (Maybe (RhsState,SPPFNode))+addSPPFEdge :: SPPFNode -> SPPFNode -> ASM ()+popGSS :: GSSNode -> (Int) -> ASM [GSSEdge]+addGSSEdge :: GSSNode -> GSSEdge -> ASM ()+getPops :: GSSNode -> ASM [Int]+joinSPPFs :: Slot -> SPPFNode -> Int -> Int -> Int + -> ASM SPPFNode+\end{code}++\begin{code}+runASM :: ASM a -> Context -> Context+runASM (ASM f) p = snd $ f p+\end{code}++%if false+\begin{code}+addSPPFEdge f t = ASM $ \((dv,pMap),r,u,gss,p) -> + ((), ((+-- dv+ insertWith (++) f [t] dv+ , + pMapInsert f t pMap +-- pMap+ )+ ,r,u,gss,p))++hasState :: RhsState -> ASM Bool+hasState alt = ASM $ \ctx@(_,_,u,_,_) -> (alt `inU` u,ctx)++newState :: SPPFNode -> RhsState -> ASM ()+newState sppf alt = ASM $ \(dv,r,u,gss,p) -> + ((), (dv, (alt,sppf):r, alt `toU` u, gss , p))++addState sppf alt@(slot,l,i) = ASM $ \(dv,r,u,gss,p) -> + let new = not (alt `inU` u) + in if new then ((), (dv, (alt,sppf):r, alt `toU` u, gss , p))+ else ((), (dv, r, u, gss, p))++getState = ASM $ \(dv,r,u,gss,p) -> + case r of + [] -> (Nothing, (dv,r,u,gss,p))+ (next:rest) -> + (Just next, (dv,rest,u,gss,p))+{- case S.size r of + 0 -> (Nothing, (dv,r,u,gss,p))+ _ -> + let ((l,i,slot,sppf),rest) = S.deleteFindMin r+ in (Just ((slot,l,i),sppf), (dv,rest,u,gss,p))-}++popGSS gn i = ASM $ \(dv,r,u,gss,p) ->+ let res = gssLookup gn gss+ in (res, (dv,r,u,gss,pInsert gn i p))+ where pInsert (x,l) i p = IM.alter inner l p+ where inner mm = case mm of + Nothing -> Just $ M.singleton x [i]+ Just m -> Just $ M.insertWith (++) x [i] m+ gssLookup (x,l) gss = maybe [] inner $ IM.lookup l gss+ where inner = maybe [] id . M.lookup x ++addGSSEdge (x,l) t = ASM $ \(dv,r,u,gss,p) -> + ((), (dv,r,u,gssInsert x l t gss,p))+ where gssInsert x l t gss = IM.alter inner l gss+ where inner mm = case mm of+ Nothing -> Just $ M.singleton x [t]+ Just m -> Just $ M.insertWith (++) x [t] m++getPops (x,i) = ASM $ \ctx@(dv,r,u,gss,p) -> (pLookup (x,i) p, ctx)+ where pLookup (x,i) p = maybe [] (maybe [] id . M.lookup x) $ IM.lookup i p++logMisMatch tau token i= ASM $ \(dv,r,u,gss,p) -> + ((), (dv,r,u,gss,p))+\end{code}+%endif++%if false+\begin{code}+instance Show GSlot where+ show (U0) = "u0"+ show (GSlot gn) = show gn++instance Show SPPFNode where+ show (SNode (s, l, r)) = "(s: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")"+ show (INode (s, l, r)) = "(i: " ++ show s ++ ", " ++ show l ++ ", " ++ show r ++ ")"+ show (PNode (p, l, k, r)) = "(p: " ++ show p ++ ", " ++ show l ++ ", " ++ show k ++ ", " ++ show r ++ ")"+ show Dummy = "$"++instance Applicative ASM where+ (<*>) = ap+ pure = return+instance Functor ASM where+ fmap = liftM+instance Monad ASM where+ return a = ASM $ \p -> (a, p)+ (ASM m) >>= f = ASM $ \p -> let (a, p') = m p+ (ASM m') = f a+ in m' p'+\end{code}+%endif++%if false+\begin{code}++parse ::Bool -> Grammar -> [Token] -> IO ()+parse debug grammar@(Grammar start _ _) input' =do+ let (resContext,prs,selects,follows) = gll debug grammar input'+ when (debug) $ do+ writeFile "/tmp/alts.txt" (unlines $ map show prs)+ writeFile "/tmp/sets.txt" (show selects ++ "\n\n" ++ show follows)+ proceed debug start (length input') resContext +++gllSPPF :: Grammar -> [Token] -> SPPF+gllSPPF grammar input = let ((sppf,_,_,_,_),_,_,_) = gll False grammar input+ in sppf++gll :: Bool -> Grammar -> [Token] -> (Context, [Alt], SelectMap, FollowMap)+gll debug (Grammar start _ rules) input' = + (runASM (pLhs (start, 0) >> pCont) context, prs, selects, follows)+ where + prs = [ alt | Rule _ alts _ <- rules, alt <- (reverse alts) ]+ context = ((M.empty,IM.empty), [], IM.empty, IM.empty, IM.empty)+ input = Array.array (0,m) $ zip [0..] $ input' ++ [EOS]+ m = length input'+\end{code}+%endif ++\begin{code}+ pCont :: ASM ()+ pLhs :: LhsState -> ASM ()+ pRhs :: RhsState -> SPPFNode -> ASM ()+\end{code}++Function |pCont| acts as the code-block starting with |L0| in a generated+GLL parser.+It takes care of the continuation of the algorithm. ++Function |pLhs| acts as the code-block starting with the label $L_{X}$, +if |pLhs| is applied to |X|.++Function |pRhs| executes the other instructions of a generated GLL parser+(including labels of the form $L_{S_1}$ and $R_{X_1}$ and instructions +that aren't labelled). +Using pattern-matching the different cases for the different symbols +in the right-hand side are given+separate definitions. +As such, each call to |pRhs| `carries+the dot' of the slot in the current state `over' the next symbol.+There is also a case for when there is no symbol for the dot to be carried over,+at which the pop and return action needs to take place.++Note that an |SPPFNode| is given as a separate argument to |pRhs| and no+|SPPFNode| is stored in the descriptors (|RhsState|).++\subsection{Main parse function}+The whole procedure is started from within the function |parse|+which receives a start-sybmol, a list of productions and an +input string (of tokens) as arguments.++\begin{spec}+parse :: Nt -> [Pr] -> [Token] -> IO () -- i/o monad+parse start prs input' = do+ proceed (runASM (pLhs (start, 0, (U0,0))) context)+ where + context = (empty, [], S.empty, empty, empty)+ input = input' ++ [EOS]+ m = length input'+\end{spec}++In its |where|-clause are the input string appended with the end-of-string +symbol |EOS| and the integer |m| which matches the number of tokens in +the (original) input string. Because the functions |pCont|, |pRhs| and+|pLhs| are defined in the same |where|-clause, this information is availaible+to all these functions.++Function |proceed| receives the context after running the entire algorithm+(running the computation represented by the |ASM| monad with |runASM|),+which is achieved by calling |pLhs| for the start symbol of the grammar+with current index |0| and initial |GSSNode| |(U0,0)|. The function+|runASM| also receives as argument the initial (empty) context.++\subsection{Continuation}+\begin{code}+ pCont = do+ mnext <- getState+ case mnext of+ Nothing -> return () -- no continuation+ Just (next,sppf) -> do f <- pRhs next sppf+ f `seq` pCont+\end{code}++The function |getSPPF| does the clerical work of finding the right+|SPPFNode| corresponding to the slot of the next descriptor. ++\subsection{Left-hand side}+Get the alternatives for which the select-test succeeds and add them to +the descriptor set |Rcal| and |Ucal|. The implementation of |addState|+ensures that no duplicates are added.++\begin{code}+ pLhs (bigx, i) = do + let alts = [ (Slot bigx [] beta, i, i) | (Alt bigx beta) <- altsOf bigx+ , select (input Array.! i) beta bigx ]+ forM_ alts (addState Dummy) +\end{code}++The code |forM_ alts addState| is equivalent to \\|forM_ alts (\r -> addState r)|+and |forM_ alts (\r -> ...)| can be read as $(\forall r \in \mathit{alts}.\;\ldots)$.+Double dash are the characters to start a single line comment (|-- comment|).++\subsection{Right-hand side}+\subsubsection{$\epsilon$-rule}+\begin{code}+ pRhs (Slot bigx [] [Term Epsilon], l, i) _ = do+ root <- joinSPPFs slot Dummy l i i+ pRhs (slot, l, i) root+ where slot = Slot bigx [Term Epsilon] []+\end{code}++\subsubsection{Terminal-case}++\begin{code}+ pRhs (Slot bigx alpha ((Term tau):beta), l, i) sppf = + when (input Array.! i == tau) $ do -- token test + root <- joinSPPFs slot sppf l i (i+1) + pRhs (slot, l, i+1) root+ where slot = Slot bigx (alpha++[Term tau]) beta+\end{code}++\begin{code}+ pRhs (Slot bigx alpha ((Nt bigy):beta), l, i) sppf = do+ when (select (input Array.! i) ((Nt bigy):beta) bigx) $ do+ addGSSEdge (bigy,i) ((slot,l), sppf)+ rs <- getPops (bigy, i) -- has ret been popped?+ forM_ rs $ \r -> do -- yes, use given extents+ root <- joinSPPFs slot sppf l i r+ addState root (slot, l, r)+ pLhs (bigy, i)+ where slot = Slot bigx (alpha++[Nt bigy]) beta+\end{code}++\begin{code}+-- pRhs (Slot bigy alpha [], 0, i) sppf _ = return () +\end{code}+\begin{code}+ pRhs (Slot bigy alpha [], l, i) ynode = do+ returns <- popGSS (bigy,l) i -- pop @&@ get child GSSNodes + forM_ returns $ \((slot',l'),sppf) -> do + root <- joinSPPFs slot' sppf l' l i -- create SPPF for lhs+ addState root (slot', l', i) -- add new descriptors+\end{code}++%if false+\begin{code}+ (prodMap,_,_,follows,selects) = fixedMaps start prs+ follow x = follows ! x+ select t rhs x = t `member` (selects ! (x,rhs))+ altsOf x = prodMap ! x+ toReturnContext (x,l,r) = IM.alter inner r+ where inner mm = case mm of + Nothing -> Just $ singleLS+ Just m -> Just $ IM.insertWith (S.union) l singleS m+ singleLS = IM.fromList [(l,singleS)]+ singleS = S.singleton x+ merge m1 m2 = IM.unionWith inner m1 m2+ where inner = IM.unionWith S.union +\end{code}+%endif++\begin{code}+joinSPPFs (Slot bigx alpha beta) sppf l k r =+ case (sppf, beta) of+-- (Dummy, _:_) -> return snode+ (Dummy, []) -> do addSPPFEdge xnode pnode+ addSPPFEdge pnode snode+ return xnode+ (_, []) -> do addSPPFEdge xnode pnode+ addSPPFEdge pnode sppf+ addSPPFEdge pnode snode+ return xnode+ _ -> do addSPPFEdge inode pnode+ addSPPFEdge pnode sppf+ addSPPFEdge pnode snode+ return inode+ where x = last alpha -- symbol before the dot+ snode = SNode (x, k, r) + xnode = SNode (Nt bigx, l, r)+ inode = INode ((Slot bigx alpha beta), l, r)+ pnode = PNode ((Slot bigx alpha beta), l, k, r)+\end{code}+%if false+\begin{code}+ inReturnContext (SNode (Nt x,l,r)) = maybe False inner . IM.lookup r+ where inner = maybe False ((x `S.member`)) . IM.lookup l+\end{code}+%endif++%if false+\begin{code}+proceed :: Bool -> Nt -> Int -> Context -> IO ()+proceed debug start m ((dv,pMap), r, u, gss, p) = do+ when debug $ do+ writeFile "/tmp/sppf.txt" (showD dv ++ "\n" ++ showP pMap)+ let success = maybe False (const True) $ lookup (SNode (Nt start,0,m)) dv+ unless success $ do+ putStrLn "no parse..."+ when (success) $ do+ putStrLn ("Descriptors: " ++ show (usize))+ putStrLn ("SPPFNodes: " ++ show (length (M.keys dv) + m))+ putStrLn ("GSSNodes: " ++ show gsssize)+ where usize = sum [ S.size s | (l, r2s) <- IM.assocs u, (r,s) <- IM.assocs r2s ]+ gsssize = 1 + sum [ length $ M.keys x2s | (l,x2s) <- IM.assocs gss ]+\end{code}+%endif
+ src/GLL/Types/Abstract.hs view
@@ -0,0 +1,39 @@+++-- UUAGC 0.9.52.1 (src/GLL/Types/Abstract.ag)+module GLL.Types.Abstract where+{-# LINE 1 "src/GLL/Types/Abstract.ag" #-}++import qualified Data.Map as M+import qualified Data.Set as S +import Data.List (delete, (\\), elemIndices, findIndices)+import GLL.Common+{-# LINE 12 "dist/build/GLL/Types/Abstract.hs" #-}+-- Alt ---------------------------------------------------------+data Alt = Alt (Nt) (Symbols)+-- Alts --------------------------------------------------------+type Alts = [Alt]+-- Grammar -----------------------------------------------------+data Grammar = Grammar (Nt) (([(String,String)])) (Rules)+-- Rule --------------------------------------------------------+data Rule = Rule (Nt) (Alts) (([Pid]))+-- Rules -------------------------------------------------------+type Rules = [Rule]+-- Slot --------------------------------------------------------+data Slot = Slot (Nt) (([Symbol])) (([Symbol]))+-- Symbol ------------------------------------------------------+data Symbol = Nt (String)+ | Term (Token)+ | Error (Token) (Token)+-- Symbols -----------------------------------------------------+type Symbols = [Symbol]+-- Token -------------------------------------------------------+data Token = Char (Char)+ | EOS+ | Epsilon+ | Int (((Maybe Int)))+ | Bool (((Maybe Bool)))+ | String (((Maybe String)))+ | Token (String) (((Maybe String)))+-- Tokens ------------------------------------------------------+type Tokens = [Token]
+ src/GLL/Types/Grammar.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE StandaloneDeriving #-}++module GLL.Types.Grammar where++import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Set as S +import qualified Data.IntSet as IS +import Data.List (delete, (\\), elemIndices, findIndices)+import GLL.Types.Abstract+import GLL.Common++token_length :: Token -> Int+token_length (Char _) = 1+token_length (EOS) = 1+token_length (Epsilon)= 0+token_length (Int _) = error "find out nr of digits in int"+token_length (Bool b) = maybe (error "no length for bool tokens") + (\b -> if b then 4 else 5) b-- supposing "True" and "False"+token_length (String s) = maybe (error "no length for string tokens") length s+token_length (Token _ str) = maybe (error "no length of tokens") length str++-- make sure that tokens are equal independent of their character level value+type SlotL = (Slot, Int) -- slot with left extent+type PrL = (Alt, Int) -- Production rule with left extent+type NtL = (Nt, Int) -- Nonterminal with left extent++-- SPPF+type PackMap = IM.IntMap (IM.IntMap (IM.IntMap (M.Map Alt IS.IntSet)))+type SymbMap = IM.IntMap (IM.IntMap (S.Set Symbol))+type SPPF = (M.Map SPPFNode ([SPPFNode]), PackMap)+data SPPFNode = SNode (Symbol, Int, Int) + | INode (Slot, Int, Int)+ | PNode (Slot, Int, Int, Int)+ | Dummy+ deriving (Ord, Eq)+type SNode = (Symbol, Int, Int)+type PNode = (Alt, [Int])+type SEdge = M.Map SNode (S.Set PNode)+type PEdge = M.Map PNode (S.Set SNode)+++pNodeLookup :: SPPF -> ((Alt, Int), Int, Int) -> Maybe [Int]+pNodeLookup (_,pMap) ((alt,j),l,r) = maybe Nothing inner $ IM.lookup l pMap+ where inner = maybe Nothing inner2 . IM.lookup r+ inner2 = maybe Nothing inner3 . IM.lookup j+ inner3 = maybe Nothing (Just . IS.toList) . M.lookup alt++pMapInsert :: SPPFNode -> SPPFNode -> PackMap -> PackMap+pMapInsert f t pMap = + case f of + PNode (Slot x alpha beta, l, k, r) -> + add (Alt x (alpha++beta)) (length alpha) l r k+ _ -> pMap+ where add alt j l r k = IM.alter addInnerL l pMap+ where addInnerL mm = case mm of + Nothing -> Just singleRJAK+ Just m -> Just $ IM.alter addInnerR r m+ addInnerR mm = case mm of+ Nothing -> Just singleJAK+ Just m -> Just $ IM.alter addInnerJ j m+ addInnerJ mm = case mm of+ Nothing -> Just singleAK+ Just m -> Just $ M.insertWith IS.union alt singleK m+ singleRJAK= IM.fromList [(r, singleJAK)]+ singleJAK = IM.fromList [(j, singleAK)]+ singleAK = M.fromList [(alt, singleK)]+ singleK = IS.singleton k+++sNodeLookup :: SymbMap -> (Symbol, Int, Int) -> Bool +sNodeLookup sm (s,l,r) = maybe False inner $ IM.lookup l sm+ where inner = maybe False (S.member s) . IM.lookup r++sNodeInsert f t sMap = + case f of+ SNode (s, l, r) -> newt (add s l r sMap)+ _ -> newt sMap+ where newt sMap = case t of + (SNode (s, l, r)) -> add s l r sMap+ _ -> sMap+ add s l r sMap = IM.alter addInnerL l sMap+ where addInnerL mm = case mm of + Nothing -> Just singleRS+ Just m -> Just $ IM.insertWith (S.union) r singleS m+ singleRS = IM.fromList [(r, singleS)]+ singleS = S.singleton s+ +sNodeRemove :: SymbMap -> (Symbol, Int, Int) -> SymbMap +sNodeRemove sm (s,l,r) = IM.adjust inner l sm+ where inner = IM.adjust ((s `S.delete`)) r++-- helpers for Ucal+inU (slot,l,i) u = maybe False inner $ IM.lookup l u+ where inner = maybe False (S.member slot) . IM.lookup i++toU (slot,l,i) u = IM.alter inner l u+ where inner mm = case mm of+ Nothing -> Just $ singleIS+ Just m -> Just $ IM.insertWith S.union i singleS m+ singleIS = IM.fromList [(i,singleS)]+ singleS = S.singleton slot+++showD dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]+showG dv = unlines [ show f ++ " --> " ++ show t | (f,ts) <- M.toList dv, t <- ts ]+showP pMap = unlines [ show ((a,j),l,r) ++ " --> " ++ show kset+ | (l,r2j) <- IM.assocs pMap, (r,j2a) <- IM.assocs r2j+ , (j,a2k) <- IM.assocs j2a, (a,kset) <- M.assocs a2k ]+showS sMap = unlines [ show (l,r) ++ " --> " ++ show (sset)+ | (l,r2s) <- IM.assocs sMap, (r,sset) <- IM.assocs r2s]+-- TODO change to Map+showSPPF :: ([(SNode,PNode)],[(PNode,SNode)]) -> String+showSPPF (se,pe) = "\n"++ (unlines $ map ppPn $ pe) ++ "\n" +++ (unlines $ map ppSn $ se)+ where ppPn ((Alt x alpha, rs), sn) = ppRhs (x,alpha,rs) ++ " --> " ++ show sn+ ppSn (sn, (Alt x alpha, rs)) = show sn ++ " --> " ++ ppRhs (x,alpha,rs)+ ppRhs (x, alpha, rs) = "(" ++ x ++ " ::= "++ (foldr ((++) . ppS) "" alpha) ++ + foldr (\i -> (("," ++ show i) ++)) "" rs ++ ")"+ ppS (Nt s) = s+ ppS (Term Epsilon) = "''"+ ppS (Term (Char c)) = [c]+ ppS (Term (Token t _)) = t+ ppS (Term (Int i)) = maybe "Int" show i+ ppS (Term (Bool b)) = maybe "Bool" show b+ ppS (Term (String s)) = maybe "String" id s+++-- smart constructors+tokenT :: Token -> Symbol+tokenT t = Term $ t+charT c = Term $ Char c+nT x = Nt x+charS = map Char +epsilon = [Term Epsilon]++type ProdMap = M.Map Nt [Alt]+type PrefixMap = M.Map (Alt,Int) ([Token], Maybe Nt)+type SelectMap = M.Map (Nt, [Symbol]) (S.Set Token)+type FirstMap = M.Map Nt (S.Set Token)+type FollowMap = M.Map Nt (S.Set Token)++fixedMaps :: Nt -> [Alt] -> (ProdMap, PrefixMap, FirstMap, FollowMap, SelectMap) +fixedMaps s prs = let f = (prodMap, prefixMap, firstMap, followMap, selectMap)+ in f `seq` f+ where+ prodMap = M.fromListWith (++) [ (x,[pr]) | pr@(Alt x _) <- prs ]++ prefixMap :: PrefixMap + prefixMap = M.fromList + [ ((pr,j), (tokens,msymb)) | pr@(Alt x alpha) <- prs+ , (j,tokens,msymb) <- prefix x alpha ]+ where+ prefix x alpha = map rangePrefix ranges+ where js = (map ((+) 1) (findIndices isNt alpha))+ ranges = zip (0:js) (js ++ [length alpha])+ rangePrefix (a,z) | a >= z = (a,[],Nothing)+ | a < z = + let init = map ((\(Term t) -> t) . (alpha !!)) [a .. (z-2)]+ last = alpha !! (z-1)+ in case last of + Nt nt -> (a,init, Just nt)+ Term t -> (a,init ++ [t], Nothing)++ firstMap = M.fromList [ (x, first_x [] x) | x <- M.keys prodMap ]++ first_x :: [Nt] -> Nt -> (S.Set Token) -- filter prevents self-calls+ first_x ys x = S.unions [ first_alpha (x:ys) rhs | Alt _ rhs <- prodMap M.! x ]+ + selectMap :: SelectMap + selectMap = M.fromList [ ((x,alpha), select alpha x) | Alt x rhs <- prs+ , alpha <- split rhs ]+ where+ split rhs = foldr op [] js+ where op j acc = drop j rhs : acc+ js = 0 : findIndices isNt rhs++ -- TODO store intermediate results+ select :: [Symbol] -> Nt -> (S.Set Token)+ select alpha x = res + where firsts = first_alpha [] alpha+ res | Epsilon `S.member` firsts = S.delete Epsilon firsts `S.union` (followMap M.! x)+ | otherwise = firsts++ -- list of symbols to get firsts from + non-terminal to ignore+ -- TODO store in map+ first_alpha :: [Nt] -> [Symbol] -> (S.Set Token)+ first_alpha ys [] = S.singleton Epsilon+ first_alpha ys (x:xs) = + case x of+ Term Epsilon -> first_alpha ys xs+ Term tau -> S.singleton tau+ Nt x -> + let fs | x `elem` ys = S.empty + | otherwise = first_x (x:ys) x+ in if x `S.member` nullableSet+ then (S.delete Epsilon fs) `S.union` first_alpha (x:ys) xs + else fs++ followMap :: M.Map Nt (S.Set Token)+ followMap = M.fromList [ (x, follow [] x) | x <- M.keys prodMap ] + + follow :: [Nt] -> Nt -> (S.Set Token)+ follow ys x = S.unions (map fw (maybe [] id $ M.lookup x localMap))+ `S.union` (if x == s then S.singleton EOS else S.empty)+ where fw (y,ss) = + let ts = S.delete Epsilon (first_alpha [] ss)+ in if nullable_alpha [] ss && not (x `elem` (y:ys))+ then ts `S.union` follow (y:ys) y + else ts+++ localMap = M.fromListWith (++)+ [ (x,[(y,tail)]) | x <- M.keys prodMap, (Alt y rhs) <- prs+ , tail <- tails x rhs ]+ where+ tails x symbs = [ drop (index + 1) symbs | index <- indices ]+ where indices = elemIndices (Nt x) symbs+ + nullableSet :: S.Set Nt+ nullableSet = S.fromList $ [ x | x <- M.keys prodMap, nullable_x [] x ]++ -- a nonterminal is nullable if any of its alternatives is empty + nullable_x :: [Nt] -> Nt -> Bool+ nullable_x ys x = or [ nullable_alpha (x:ys) rhs + | (Alt _ rhs) <- prodMap M.! x ] ++ -- TODO store in map+ nullable_alpha :: [Nt] -> [Symbol] -> Bool+ nullable_alpha ys [] = True+ nullable_alpha ys (s:ss) = + case s of+ Nt nt -> if nt `elem` ys + then False --nullable only if some other alternative is nullable+ else nullable_x ys nt && nullable_alpha (nt:ys) ss+ Term Epsilon -> True+ otherwise -> False++-- some helpers+isNt (Nt _) = True+isNt _ = False++isTerm (Term _) = True+isTerm _ = False++isChar (Char _) = True+isChar _ = False ++deriving instance Show Grammar +deriving instance Ord Slot+deriving instance Eq Slot+deriving instance Show Rule+deriving instance Show Alt+deriving instance Ord Alt+deriving instance Eq Alt+deriving instance Show Symbol+deriving instance Eq Symbol+deriving instance Ord Symbol++{-+instance Show Symbol where+ show (Nt nt) = "Nt " ++ show nt+ show (Term t) = "Term " ++ show t+ show (Error t1 t2) = "Error " ++ show t1 ++ " " ++ show t2++instance Eq Symbol where+ (Nt nt) == (Nt nt') = nt == nt'+ (Term t) == (Term t') = t == t'+ (Error t1 t2) == (Error t1' t2') = (t1,t2) == (t1',t2')++instance Ord Symbol where+ (Nt nt) `compare` (Nt nt') = nt `compare` nt+ (Nt _) `compare` _ = LT+ _ `compare` (Nt _) = GT+ (Term t) `compare` (Term t') = t `compare` t'+ (Term _) `compare` _ = LT+ _ `compare` (Term _) = GT+ (Error t1 t2) `compare` (Error t1' t2') = (t1,t2) `compare` (t1',t2')+-}++instance Eq Token where+ Token k _ == Token k' _ = k' == k+ Char c == Char c' = c' == c+ EOS == EOS = True+ Epsilon == Epsilon = True+ String _ == String _ = True+ Int _ == Int _ = True+ Bool _ == Bool _ = True+ _ == _ = False++instance Ord Token where+ EOS `compare` EOS = EQ + EOS `compare` _ = LT+ _ `compare` EOS = GT+ Epsilon `compare` Epsilon = EQ+ Epsilon `compare` _ = LT+ _ `compare` Epsilon = GT+ String _ `compare` String _ = EQ+ String _ `compare` _ = LT+ _ `compare` String _ = GT+ Int _ `compare` Int _ = EQ+ Int _ `compare` _ = LT+ _ `compare` Int _ = GT+ Bool _ `compare` Bool _ = EQ+ Bool _ `compare` _ = LT+ _ `compare` Bool _ = GT+ Char c `compare` Char c2 = c `compare` c2+ Char _ `compare` _ = LT+ _ `compare` Char c = GT+ Token k _ `compare` Token k2 _ = k `compare` k2++instance Show Token where+ show (Char c) = "Char(" ++ show [c] ++ ")"+ show (EOS) = "$"+ show Epsilon = "#"+ show (Int mi) = "Int(" ++ maybe "_" show mi ++ ")"+ show (Bool mb)= "Bool(" ++ maybe "_" show mb ++ ")"+ show (String ms) = "String("++ maybe "_" show ms ++ ")"+ show (Token t ms) = t ++ "(" ++ maybe "_" show ms ++ ")"+++instance Show Slot where+ show (Slot x alpha beta) = x ++ " ::= " ++ showRhs alpha ++ "." ++ showRhs beta + where showRhs [] = ""+ showRhs ((Term t):rhs) = show t ++ showRhs rhs+ showRhs ((Nt x):rhs) = x ++ showRhs rhs+