diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gll.cabal b/gll.cabal new file mode 100644 --- /dev/null +++ b/gll.cabal @@ -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 + + diff --git a/src/GLL/Combinators/Combinators.hs b/src/GLL/Combinators/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Combinators/Combinators.hs @@ -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 ,\_ _ _ _ _ -> [()]) diff --git a/src/GLL/Common.hs b/src/GLL/Common.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Common.hs @@ -0,0 +1,4 @@ +module GLL.Common where + +type Nt = String +type Pid = String diff --git a/src/GLL/Machines/RGLL.lhs b/src/GLL/Machines/RGLL.lhs new file mode 100644 --- /dev/null +++ b/src/GLL/Machines/RGLL.lhs @@ -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 diff --git a/src/GLL/Types/Abstract.hs b/src/GLL/Types/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Types/Abstract.hs @@ -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] diff --git a/src/GLL/Types/Grammar.hs b/src/GLL/Types/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/GLL/Types/Grammar.hs @@ -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 +