forked from GitHub/gf-core
150 lines
5.0 KiB
Haskell
150 lines
5.0 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : EBNF
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/04/21 16:21:13 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.5 $
|
|
--
|
|
-- (Description of the module)
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Grammar.EBNF (EBNF, ERule, ERHS(..), ebnf2cf) where
|
|
|
|
import GF.Data.Operations
|
|
import GF.Grammar.CFG
|
|
|
|
type EBNF = [ERule]
|
|
type ERule = (ECat, ERHS)
|
|
type ECat = (String,[Int])
|
|
type ETok = String
|
|
|
|
data ERHS =
|
|
ETerm ETok
|
|
| ENonTerm ECat
|
|
| ESeq ERHS ERHS
|
|
| EAlt ERHS ERHS
|
|
| EStar ERHS
|
|
| EPlus ERHS
|
|
| EOpt ERHS
|
|
| EEmpty
|
|
|
|
type CFRHS = [ParamCFSymbol]
|
|
type CFJustRule = ((Cat,[Param]), CFRHS)
|
|
|
|
ebnf2cf :: EBNF -> [ParamCFRule]
|
|
ebnf2cf ebnf =
|
|
[Rule cat items (mkCFF i cat) | (i,(cat,items)) <- zip [0..] (normEBNF ebnf)]
|
|
where
|
|
mkCFF i (c,_) = CFObj ("Mk" ++ c ++ "_" ++ show i) []
|
|
|
|
normEBNF :: EBNF -> [CFJustRule]
|
|
normEBNF erules = let
|
|
erules1 = [normERule ([i],r) | (i,r) <- zip [0..] erules]
|
|
erules2 = erules1 ---refreshECats erules1 --- this seems to be just bad !
|
|
erules3 = concat (map pickERules erules2)
|
|
--erules4 = nubERules erules3
|
|
in [(mkCFCatE cat, map eitem2cfitem its) | (cat,itss) <- erules3, its <- itss]
|
|
{-
|
|
refreshECats :: [NormERule] -> [NormERule]
|
|
refreshECats rules = [recas [i] rule | (i,rule) <- zip [0..] rules] where
|
|
recas ii (cat,its) = (updECat ii cat, [recss ii 0 s | s <- its])
|
|
recss ii n [] = []
|
|
recss ii n (s:ss) = recit (ii ++ [n]) s : recss ii (n+1) ss
|
|
recit ii it = case it of
|
|
EINonTerm cat -> EINonTerm (updECat ii cat)
|
|
EIStar (cat,t) -> EIStar (updECat ii cat, [recss ii 0 s | s <- t])
|
|
EIPlus (cat,t) -> EIPlus (updECat ii cat, [recss ii 0 s | s <- t])
|
|
EIOpt (cat,t) -> EIOpt (updECat ii cat, [recss ii 0 s | s <- t])
|
|
_ -> it
|
|
-}
|
|
pickERules :: NormERule -> [NormERule]
|
|
pickERules rule@(cat,alts) = rule : concat (map pics (concat alts)) where
|
|
pics it = case it of
|
|
EIStar ru@(cat,t) -> mkEStarRules cat ++ pickERules ru
|
|
EIPlus ru@(cat,t) -> mkEPlusRules cat ++ pickERules ru
|
|
EIOpt ru@(cat,t) -> mkEOptRules cat ++ pickERules ru
|
|
_ -> []
|
|
mkEStarRules cat = [(cat', [[],[EINonTerm cat, EINonTerm cat']])]
|
|
where cat' = mkNewECat cat "Star"
|
|
mkEPlusRules cat = [(cat', [[EINonTerm cat],[EINonTerm cat, EINonTerm cat']])]
|
|
where cat' = mkNewECat cat "Plus"
|
|
mkEOptRules cat = [(cat', [[],[EINonTerm cat]])]
|
|
where cat' = mkNewECat cat "Opt"
|
|
{-
|
|
nubERules :: [NormERule] -> [NormERule]
|
|
nubERules rules = nub optim where
|
|
optim = map (substERules (map mkSubst replaces)) irreducibles
|
|
(replaces,irreducibles) = partition reducible rules
|
|
reducible (cat,[items]) = isNewCat cat && all isOldIt items
|
|
reducible _ = False
|
|
isNewCat (_,ints) = ints == []
|
|
isOldIt (EITerm _) = True
|
|
isOldIt (EINonTerm cat) = not (isNewCat cat)
|
|
isOldIt _ = False
|
|
mkSubst (cat,its) = (cat, head its) -- def of reducible: its must be singleton
|
|
--- the optimization assumes each cat has at most one EBNF rule.
|
|
|
|
substERules :: [(ECat,[EItem])] -> NormERule -> NormERule
|
|
substERules g (cat,itss) = (cat, map sub itss) where
|
|
sub [] = []
|
|
sub (i@(EINonTerm cat') : ii) = case lookup cat g of
|
|
Just its -> its ++ sub ii
|
|
_ -> i : sub ii
|
|
sub (EIStar r : ii) = EIStar (substERules g r) : ii
|
|
sub (EIPlus r : ii) = EIPlus (substERules g r) : ii
|
|
sub (EIOpt r : ii) = EIOpt (substERules g r) : ii
|
|
-}
|
|
eitem2cfitem :: EItem -> ParamCFSymbol
|
|
eitem2cfitem it = case it of
|
|
EITerm a -> Terminal a
|
|
EINonTerm cat -> NonTerminal (mkCFCatE cat)
|
|
EIStar (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Star"))
|
|
EIPlus (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Plus"))
|
|
EIOpt (cat,_) -> NonTerminal (mkCFCatE (mkNewECat cat "Opt"))
|
|
|
|
type NormERule = (ECat,[[EItem]]) -- disjunction of sequences of items
|
|
|
|
data EItem =
|
|
EITerm String
|
|
| EINonTerm ECat
|
|
| EIStar NormERule
|
|
| EIPlus NormERule
|
|
| EIOpt NormERule
|
|
deriving Eq
|
|
|
|
normERule :: ([Int],ERule) -> NormERule
|
|
normERule (ii,(cat,rhs)) =
|
|
(cat,[map (mkEItem (ii ++ [i])) r' | (i,r') <- zip [0..] (disjNorm rhs)]) where
|
|
disjNorm r = case r of
|
|
ESeq r1 r2 -> [x ++ y | x <- disjNorm r1, y <- disjNorm r2]
|
|
EAlt r1 r2 -> disjNorm r1 ++ disjNorm r2
|
|
EEmpty -> [[]]
|
|
_ -> [[r]]
|
|
|
|
mkEItem :: [Int] -> ERHS -> EItem
|
|
mkEItem ii rhs = case rhs of
|
|
ETerm a -> EITerm a
|
|
ENonTerm cat -> EINonTerm cat
|
|
EStar r -> EIStar (normERule (ii,(mkECat ii, r)))
|
|
EPlus r -> EIPlus (normERule (ii,(mkECat ii, r)))
|
|
EOpt r -> EIOpt (normERule (ii,(mkECat ii, r)))
|
|
_ -> EINonTerm ("?????",[])
|
|
-- _ -> error "should not happen in ebnf" ---
|
|
|
|
mkECat ints = ("C", ints)
|
|
|
|
prECat (c,[]) = c
|
|
prECat (c,ints) = c ++ "_" ++ prTList "_" (map show ints)
|
|
|
|
mkCFCatE :: ECat -> (Cat,[Param])
|
|
mkCFCatE c = (prECat c,[0])
|
|
{-
|
|
updECat _ (c,[]) = (c,[])
|
|
updECat ii (c,_) = (c,ii)
|
|
-}
|
|
mkNewECat (c,ii) str = (c ++ str,ii)
|