forked from GitHub/gf-core
119 lines
3.6 KiB
Haskell
119 lines
3.6 KiB
Haskell
module GF.GFCC.Raw.ConvertGFCC where
|
|
|
|
import GF.GFCC.DataGFCC
|
|
import GF.GFCC.Raw.AbsGFCCRaw
|
|
|
|
import Data.Map
|
|
|
|
-- convert parsed grammar to internal GFCC
|
|
|
|
mkGFCC :: Grammar -> GFCC
|
|
mkGFCC (Grm [
|
|
App (CId "abstract") [AId a],
|
|
App (CId "concrete") cs,
|
|
App (CId "flags") gfs,
|
|
ab@(
|
|
App (CId "abstract") [
|
|
App (CId "flags") afls,
|
|
App (CId "fun") fs,
|
|
App (CId "cat") cts
|
|
]),
|
|
App (CId "concrete") ccs
|
|
]) = GFCC {
|
|
absname = a,
|
|
cncnames = [c | AId c <- cs],
|
|
gflags = fromAscList [(f,v) | App f [AStr v] <- gfs],
|
|
abstract =
|
|
let
|
|
aflags = fromAscList [(f,v) | App f [AStr v] <- afls]
|
|
lfuns = [(f,(toType typ,toExp def)) | App f [typ, def] <- fs]
|
|
funs = fromAscList lfuns
|
|
lcats = [(c, Prelude.map toHypo hyps) | App c hyps <- cts]
|
|
cats = fromAscList lcats
|
|
catfuns = fromAscList
|
|
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
|
in Abstr aflags funs cats catfuns,
|
|
concretes = fromAscList (lmap mkCnc ccs)
|
|
}
|
|
where
|
|
mkCnc (
|
|
App (CId "concrete") [
|
|
AId lang,
|
|
App (CId "flags") fls,
|
|
App (CId "lin") ls,
|
|
App (CId "oper") ops,
|
|
App (CId "lincat") lincs,
|
|
App (CId "lindef") linds,
|
|
App (CId "printname") prns,
|
|
App (CId "param") params
|
|
]) = (lang,
|
|
Concr {
|
|
cflags = fromAscList [(f,v) | App f [AStr v] <- afls],
|
|
lins = fromAscList [(f,toTerm v) | App f [v] <- ls],
|
|
opers = fromAscList [(f,toTerm v) | App f [v] <- ops],
|
|
lincats = fromAscList [(f,toTerm v) | App f [v] <- lincs],
|
|
lindefs = fromAscList [(f,toTerm v) | App f [v] <- linds],
|
|
printnames = fromAscList [(f,toTerm v) | App f [v] <- prns],
|
|
paramlincats = fromAscList [(f,toTerm v) | App f [v] <- params]
|
|
}
|
|
)
|
|
|
|
toType :: RExp -> Type
|
|
toType e = case e of
|
|
App cat [App (CId "hypo") hypos, App (CId "arg") exps] ->
|
|
DTyp (lmap toHypo hypos) cat (lmap toExp exps)
|
|
_ -> error $ "type " ++ show e
|
|
|
|
toHypo :: RExp -> Hypo
|
|
toHypo e = case e of
|
|
App x [typ] -> Hyp x (toType typ)
|
|
_ -> error $ "hypo " ++ show e
|
|
|
|
toExp :: RExp -> Exp
|
|
toExp e = case e of
|
|
App fun [App (CId "abs") xs, App (CId "arg") exps] ->
|
|
DTr [x | AId x <- xs] (AC fun) (lmap toExp exps)
|
|
_ -> error $ "exp " ++ show e
|
|
|
|
toTerm :: RExp -> Term
|
|
toTerm e = case e of
|
|
App (CId "R") es -> R (lmap toTerm es)
|
|
App (CId "S") es -> S (lmap toTerm es)
|
|
App (CId "FV") es -> FV (lmap toTerm es)
|
|
App (CId "P") [e,v] -> P (toTerm e) (toTerm v)
|
|
App (CId "RP") [e,v] -> RP (toTerm e) (toTerm v) ----
|
|
App (CId "W") [AStr s,v] -> W s (toTerm v)
|
|
AInt i -> C (fromInteger i)
|
|
AMet -> TM
|
|
AId f -> F f
|
|
App (CId "A") [AInt i] -> V (fromInteger i)
|
|
AStr s -> K (KS s) ----
|
|
_ -> error $ "term " ++ show e
|
|
|
|
|
|
{-
|
|
-- convert internal GFCC and pretty-print it
|
|
|
|
printGFCC :: GFCC -> String
|
|
printGFCC gfcc0 = compactPrintGFCC $ printTree $ Grm
|
|
(absname gfcc)
|
|
(cncnames gfcc)
|
|
[Flg f v | (f,v) <- assocs (gflags gfcc)]
|
|
(Abs
|
|
[Flg f v | (f,v) <- assocs (aflags (abstract gfcc))]
|
|
[Fun f ty df | (f,(ty,df)) <- assocs (funs (abstract gfcc))]
|
|
[Cat f v | (f,v) <- assocs (cats (abstract gfcc))]
|
|
)
|
|
[fromCnc lang cnc | (lang,cnc) <- assocs (concretes gfcc)]
|
|
where
|
|
fromCnc lang cnc = Cnc lang
|
|
[Flg f v | (f,v) <- assocs (cflags cnc)]
|
|
[Lin f v | (f,v) <- assocs (lins cnc)]
|
|
[Lin f v | (f,v) <- assocs (opers cnc)]
|
|
[Lin f v | (f,v) <- assocs (lincats cnc)]
|
|
[Lin f v | (f,v) <- assocs (lindefs cnc)]
|
|
[Lin f v | (f,v) <- assocs (printnames cnc)]
|
|
[Lin f v | (f,v) <- assocs (paramlincats cnc)]
|
|
gfcc = utf8GFCC gfcc0
|
|
-}
|