forked from GitHub/gf-core
135 lines
4.8 KiB
Haskell
135 lines
4.8 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
module GF.Compile.CFGtoPGF (cf2pgf) where
|
|
|
|
import GF.Grammar.CFG
|
|
import GF.Infra.UseIO
|
|
|
|
import PGF
|
|
import PGF.Internal
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import qualified Data.IntMap as IntMap
|
|
import Data.Array.IArray
|
|
import Data.List
|
|
|
|
--------------------------
|
|
-- the compiler ----------
|
|
--------------------------
|
|
|
|
cf2pgf :: FilePath -> ParamCFG -> PGF
|
|
cf2pgf fpath cf =
|
|
let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
|
|
in updateProductionIndices pgf
|
|
where
|
|
name = justModuleName fpath
|
|
aname = mkCId (name ++ "Abs")
|
|
cname = mkCId name
|
|
|
|
cf2abstr :: ParamCFG -> Abstr
|
|
cf2abstr cfg = Abstr aflags afuns acats
|
|
where
|
|
aflags = Map.singleton (mkCId "startcat") (LStr (fst (cfgStartCat cfg)))
|
|
|
|
acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
|
|
| (cat,rules) <- (Map.toList . Map.fromListWith (++))
|
|
[(cat2id cat, catRules cfg cat) |
|
|
cat <- allCats' cfg]]
|
|
afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
|
|
| rule <- allRules cfg]
|
|
|
|
cat2id = mkCId . fst
|
|
|
|
cf2concr :: ParamCFG -> Concr
|
|
cf2concr cfg = Concr Map.empty Map.empty
|
|
cncfuns lindefsrefs lindefsrefs
|
|
sequences productions
|
|
IntMap.empty Map.empty
|
|
cnccats
|
|
IntMap.empty
|
|
totalCats
|
|
where
|
|
cats = allCats' cfg
|
|
rules = allRules cfg
|
|
|
|
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
|
|
map mkSequence rules)
|
|
sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
|
|
|
|
idFun = CncFun wildCId (listArray (0,0) [seqid])
|
|
where
|
|
seq = listArray (0,0) [SymCat 0 0]
|
|
seqid = binSearch seq sequences (bounds sequences)
|
|
((fun_cnt,cncfuns0),productions0) = mapAccumL (convertRule cs) (1,[idFun]) rules
|
|
productions = foldl addProd IntMap.empty (concat (productions0++coercions))
|
|
cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
|
|
|
|
lbls = listArray (0,0) ["s"]
|
|
(fid,cnccats0) = (mapAccumL mkCncCat 0 . Map.toList . Map.fromListWith max)
|
|
[(c,p) | (c,ps) <- cats, p <- ps]
|
|
((totalCats,cs), coercions) = mapAccumL mkCoercions (fid,Map.empty) cats
|
|
cnccats = Map.fromList cnccats0
|
|
|
|
lindefsrefs =
|
|
IntMap.fromList (map mkLinDefRef cats)
|
|
|
|
convertRule cs (funid,funs) rule =
|
|
let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule]
|
|
prod = PApply funid args
|
|
seqid = binSearch (mkSequence rule) sequences (bounds sequences)
|
|
fun = CncFun (mkRuleName rule) (listArray (0,0) [seqid])
|
|
funid' = funid+1
|
|
in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps])
|
|
|
|
mkSequence rule = listArray (0,length syms-1) syms
|
|
where
|
|
syms = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
|
|
|
|
convertSymbol d (NonTerminal (c,_)) = (d+1,if c `elem` ["Int","Float","String"] then SymLit d 0 else SymCat d 0)
|
|
convertSymbol d (Terminal t) = (d, SymKS t)
|
|
|
|
mkCncCat fid (cat,n)
|
|
| cat == "Int" = (fid, (mkCId cat, CncCat fidInt fidInt lbls))
|
|
| cat == "Float" = (fid, (mkCId cat, CncCat fidFloat fidFloat lbls))
|
|
| cat == "String" = (fid, (mkCId cat, CncCat fidString fidString lbls))
|
|
| otherwise = let fid' = fid+n+1
|
|
in fid' `seq` (fid', (mkCId cat,CncCat fid (fid+n) lbls))
|
|
|
|
mkCoercions (fid,cs) c@(cat,[p]) = ((fid,cs),[])
|
|
mkCoercions (fid,cs) c@(cat,ps ) =
|
|
let fid' = fid+1
|
|
in fid' `seq` ((fid', Map.insert c fid cs), [(fid,PCoerce (cat2fid cat p)) | p <- ps])
|
|
|
|
mkLinDefRef (cat,_) =
|
|
(cat2fid cat 0,[0])
|
|
|
|
addProd prods (fid,prod) =
|
|
case IntMap.lookup fid prods of
|
|
Just set -> IntMap.insert fid (Set.insert prod set) prods
|
|
Nothing -> IntMap.insert fid (Set.singleton prod) prods
|
|
|
|
binSearch v arr (i,j)
|
|
| i <= j = case compare v (arr ! k) of
|
|
LT -> binSearch v arr (i,k-1)
|
|
EQ -> k
|
|
GT -> binSearch v arr (k+1,j)
|
|
| otherwise = error "binSearch"
|
|
where
|
|
k = (i+j) `div` 2
|
|
|
|
cat2fid cat p =
|
|
case Map.lookup (mkCId cat) cnccats of
|
|
Just (CncCat fid _ _) -> fid+p
|
|
_ -> error "cat2fid"
|
|
|
|
cat2arg c@(cat,[p]) = cat2fid cat p
|
|
cat2arg c@(cat,ps ) =
|
|
case Map.lookup c cs of
|
|
Just fid -> fid
|
|
Nothing -> error "cat2arg"
|
|
|
|
mkRuleName rule =
|
|
case ruleName rule of
|
|
CFObj n _ -> n
|
|
_ -> wildCId
|