mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-12 20:52:50 -06:00
f739841497
PGF exports the public, stable API. PGF.Internal exports additional things needed in the GF compiler & shell, including the nonstardard version of Data.Binary.
110 lines
3.8 KiB
Haskell
110 lines
3.8 KiB
Haskell
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 qualified Data.ByteString as BS
|
|
import Data.Array.IArray
|
|
import Data.List
|
|
|
|
--------------------------
|
|
-- the compiler ----------
|
|
--------------------------
|
|
|
|
cf2pgf :: FilePath -> CFG -> 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 :: CFG -> Abstr
|
|
cf2abstr cfg = Abstr aflags afuns acats BS.empty
|
|
where
|
|
aflags = Map.singleton (mkCId "startcat") (LStr (cfgStartCat cfg))
|
|
acats = Map.fromList [(mkCId cat, ([], [(0,mkRuleName rule)
|
|
| rule <- Set.toList rules], 0, 0))
|
|
| (cat,rules) <- Map.toList (cfgRules cfg)]
|
|
afuns = Map.fromList [(mkRuleName rule, (cftype [mkCId c | NonTerminal c <- ruleRhs rule] (mkCId cat), 0, Nothing, 0, 0))
|
|
| (cat,rules) <- Map.toList (cfgRules cfg)
|
|
, rule <- Set.toList rules]
|
|
|
|
cf2concr :: CFG -> Concr
|
|
cf2concr cfg = Concr Map.empty Map.empty
|
|
cncfuns lindefsrefs lindefsrefs
|
|
sequences productions
|
|
IntMap.empty Map.empty
|
|
cnccats
|
|
IntMap.empty
|
|
totalCats
|
|
where
|
|
sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
|
|
[mkSequence rule | rules <- Map.elems (cfgRules cfg), rule <- Set.toList 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 convertRules (1,[idFun]) (Map.toList (cfgRules cfg))
|
|
productions = IntMap.fromList productions0
|
|
cncfuns = listArray (0,fun_cnt-1) (reverse cncfuns0)
|
|
|
|
lbls = listArray (0,0) ["s"]
|
|
(totalCats,cnccats0) = mapAccumL mkCncCat 0 (Map.toList (cfgRules cfg))
|
|
cnccats = Map.fromList cnccats0
|
|
|
|
lindefsrefs =
|
|
IntMap.fromList (map mkLinDefRef (Map.keys (cfgRules cfg)))
|
|
|
|
convertRules st (cat,rules) =
|
|
let (st',prods) = mapAccumL convertRule st (Set.toList rules)
|
|
in (st',(cat2fid cat,Set.fromList prods))
|
|
|
|
convertRule (funid,funs) rule =
|
|
let args = [PArg [] (cat2fid 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),prod)
|
|
|
|
mkSequence rule = listArray (0,length syms-1) syms
|
|
where
|
|
syms = snd $ mapAccumL convertSymbol 0 (ruleRhs rule)
|
|
|
|
convertSymbol d (NonTerminal _) = (d+1,SymCat d 0)
|
|
convertSymbol d (Terminal t) = (d, SymKS t)
|
|
|
|
mkCncCat fid (cat,_) = (fid+1, (mkCId cat,CncCat fid fid lbls))
|
|
|
|
mkLinDefRef cat =
|
|
(cat2fid cat,[0])
|
|
|
|
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 =
|
|
case Map.lookup (mkCId cat) cnccats of
|
|
Just (CncCat fid _ _) -> fid
|
|
_ -> error "cat2fid"
|
|
|
|
mkRuleName rule =
|
|
case ruleName rule of
|
|
CFObj n _ -> n
|
|
_ -> wildCId
|