forked from GitHub/gf-core
272 lines
9.6 KiB
Haskell
272 lines
9.6 KiB
Haskell
module PGF.Raw.Convert (toPGF,fromPGF) where
|
|
|
|
import PGF.CId
|
|
import PGF.Data
|
|
import PGF.Raw.Abstract
|
|
|
|
import Data.Array.IArray
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.IntMap as IntMap
|
|
|
|
pgfMajorVersion, pgfMinorVersion :: Integer
|
|
(pgfMajorVersion, pgfMinorVersion) = (1,0)
|
|
|
|
-- convert parsed grammar to internal PGF
|
|
|
|
toPGF :: Grammar -> PGF
|
|
toPGF (Grm [
|
|
App "pgf" (AInt v1 : AInt v2 : App a []:cs),
|
|
App "flags" gfs,
|
|
ab@(
|
|
App "abstract" [
|
|
App "fun" fs,
|
|
App "cat" cts
|
|
]),
|
|
App "concrete" ccs
|
|
]) = let pgf = PGF {
|
|
absname = mkCId a,
|
|
cncnames = [mkCId c | App c [] <- cs],
|
|
gflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs],
|
|
abstract =
|
|
let
|
|
aflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- gfs]
|
|
lfuns = [(mkCId f,(toType typ,toExp def)) | App f [typ, def] <- fs]
|
|
funs = Map.fromAscList lfuns
|
|
lcats = [(mkCId c, Prelude.map toHypo hyps) | App c hyps <- cts]
|
|
cats = Map.fromAscList lcats
|
|
catfuns = Map.fromAscList
|
|
[(cat,[f | (f, (DTyp _ c _,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
|
|
in Abstr aflags funs cats catfuns,
|
|
concretes = Map.fromAscList [(mkCId lang, toConcr pgf ts) | App lang ts <- ccs]
|
|
}
|
|
in pgf
|
|
where
|
|
|
|
toConcr :: PGF -> [RExp] -> Concr
|
|
toConcr pgf rexp =
|
|
let cnc = foldl add (Concr {cflags = Map.empty,
|
|
lins = Map.empty,
|
|
opers = Map.empty,
|
|
lincats = Map.empty,
|
|
lindefs = Map.empty,
|
|
printnames = Map.empty,
|
|
paramlincats = Map.empty,
|
|
parser = Nothing
|
|
}) rexp
|
|
in cnc
|
|
where
|
|
add :: Concr -> RExp -> Concr
|
|
add cnc (App "flags" ts) = cnc { cflags = Map.fromAscList [(mkCId f,v) | App f [AStr v] <- ts] }
|
|
add cnc (App "lin" ts) = cnc { lins = mkTermMap ts }
|
|
add cnc (App "oper" ts) = cnc { opers = mkTermMap ts }
|
|
add cnc (App "lincat" ts) = cnc { lincats = mkTermMap ts }
|
|
add cnc (App "lindef" ts) = cnc { lindefs = mkTermMap ts }
|
|
add cnc (App "printname" ts) = cnc { printnames = mkTermMap ts }
|
|
add cnc (App "param" ts) = cnc { paramlincats = mkTermMap ts }
|
|
add cnc (App "parser" ts) = cnc { parser = Just (toPInfo ts) }
|
|
|
|
toPInfo :: [RExp] -> ParserInfo
|
|
toPInfo [App "functions" fs, App "sequences" ss, App "productions" ps,App "categories" (t:cs)] =
|
|
ParserInfo { functions = functions
|
|
, sequences = seqs
|
|
, productions = productions
|
|
, startCats = cats
|
|
, totalCats = expToInt t
|
|
}
|
|
where
|
|
functions = mkArray (map toFFun fs)
|
|
seqs = mkArray (map toFSeq ss)
|
|
productions = IntMap.fromList (map toProductionSet ps)
|
|
cats = Map.fromList [(mkCId c, (map expToInt xs)) | App c xs <- cs]
|
|
|
|
toFFun :: RExp -> FFun
|
|
toFFun (App f [App "P" ts,App "R" ls]) = FFun fun prof lins
|
|
where
|
|
fun = mkCId f
|
|
prof = map toProfile ts
|
|
lins = mkArray [fromIntegral seqid | AInt seqid <- ls]
|
|
|
|
toProfile :: RExp -> Profile
|
|
toProfile AMet = []
|
|
toProfile (App "_A" [t]) = [expToInt t]
|
|
toProfile (App "_U" ts) = [expToInt t | App "_A" [t] <- ts]
|
|
|
|
toFSeq :: RExp -> FSeq
|
|
toFSeq (App "seq" ss) = mkArray [toSymbol s | s <- ss]
|
|
|
|
toProductionSet :: RExp -> (FCat,Set.Set Production)
|
|
toProductionSet (App "td" (rt : xs)) = (expToInt rt, Set.fromList (map toProduction xs))
|
|
where
|
|
toProduction (App "A" (ruleid : at)) = FApply (expToInt ruleid) (map expToInt at)
|
|
toProduction (App "C" [fcat]) = FCoerce (expToInt fcat)
|
|
|
|
toSymbol :: RExp -> FSymbol
|
|
toSymbol (App "P" [n,l]) = FSymCat (expToInt n) (expToInt l)
|
|
toSymbol (App "KP" (d:alts)) = FSymTok (toKP d alts)
|
|
toSymbol (AStr t) = FSymTok (KS t)
|
|
|
|
toType :: RExp -> Type
|
|
toType e = case e of
|
|
App cat [App "H" hypos, App "X" exps] ->
|
|
DTyp (map toHypo hypos) (mkCId cat) (map toExp exps)
|
|
_ -> error $ "type " ++ show e
|
|
|
|
toHypo :: RExp -> Hypo
|
|
toHypo e = case e of
|
|
App x [typ] -> Hyp (mkCId x) (toType typ)
|
|
_ -> error $ "hypo " ++ show e
|
|
|
|
toExp :: RExp -> Expr
|
|
toExp e = case e of
|
|
App "Abs" [App x [], exp] -> EAbs (mkCId x) (toExp exp)
|
|
App "App" [e1,e2] -> EApp (toExp e1) (toExp e2)
|
|
App "Eq" eqs -> EEq [Equ (map toExp ps) (toExp v) | App "E" (v:ps) <- eqs]
|
|
App "Var" [App i []] -> EVar (mkCId i)
|
|
AMet -> EMeta 0
|
|
AInt i -> ELit (LInt i)
|
|
AFlt i -> ELit (LFlt i)
|
|
AStr i -> ELit (LStr i)
|
|
_ -> error $ "exp " ++ show e
|
|
|
|
toTerm :: RExp -> Term
|
|
toTerm e = case e of
|
|
App "R" es -> R (map toTerm es)
|
|
App "S" es -> S (map toTerm es)
|
|
App "FV" es -> FV (map toTerm es)
|
|
App "P" [e,v] -> P (toTerm e) (toTerm v)
|
|
App "W" [AStr s,v] -> W s (toTerm v)
|
|
App "A" [AInt i] -> V (fromInteger i)
|
|
App f [] -> F (mkCId f)
|
|
AInt i -> C (fromInteger i)
|
|
AMet -> TM "?"
|
|
App "KP" (d:alts) -> K (toKP d alts)
|
|
AStr s -> K (KS s)
|
|
_ -> error $ "term " ++ show e
|
|
|
|
toKP d alts = KP (toStr d) (map toAlt alts)
|
|
where
|
|
toStr (App "S" vs) = [v | AStr v <- vs]
|
|
toAlt (App "A" [x,y]) = Alt (toStr x) (toStr y)
|
|
|
|
|
|
------------------------------
|
|
--- from internal to parser --
|
|
------------------------------
|
|
|
|
fromPGF :: PGF -> Grammar
|
|
fromPGF pgf = Grm [
|
|
App "pgf" (AInt pgfMajorVersion:AInt pgfMinorVersion
|
|
: App (prCId (absname pgf)) [] : map (flip App [] . prCId) (cncnames pgf)),
|
|
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (gflags pgf `Map.union` aflags apgf)],
|
|
App "abstract" [
|
|
App "fun" [App (prCId f) [fromType t,fromExp d] | (f,(t,d)) <- Map.toList (funs apgf)],
|
|
App "cat" [App (prCId f) (map fromHypo hs) | (f,hs) <- Map.toList (cats apgf)]
|
|
],
|
|
App "concrete" [App (prCId lang) (fromConcrete c) | (lang,c) <- Map.toList (concretes pgf)]
|
|
]
|
|
where
|
|
apgf = abstract pgf
|
|
fromConcrete cnc = [
|
|
App "flags" [App (prCId f) [AStr v] | (f,v) <- Map.toList (cflags cnc)],
|
|
App "lin" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lins cnc)],
|
|
App "oper" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (opers cnc)],
|
|
App "lincat" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lincats cnc)],
|
|
App "lindef" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (lindefs cnc)],
|
|
App "printname" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (printnames cnc)],
|
|
App "param" [App (prCId f) [fromTerm v] | (f,v) <- Map.toList (paramlincats cnc)]
|
|
] ++ maybe [] (\p -> [fromPInfo p]) (parser cnc)
|
|
|
|
fromType :: Type -> RExp
|
|
fromType e = case e of
|
|
DTyp hypos cat exps ->
|
|
App (prCId cat) [
|
|
App "H" (map fromHypo hypos),
|
|
App "X" (map fromExp exps)]
|
|
|
|
fromHypo :: Hypo -> RExp
|
|
fromHypo e = case e of
|
|
Hyp x typ -> App (prCId x) [fromType typ]
|
|
|
|
fromExp :: Expr -> RExp
|
|
fromExp e = case e of
|
|
EAbs x exp -> App "Abs" [App (prCId x) [], fromExp exp]
|
|
EApp e1 e2 -> App "App" [fromExp e1, fromExp e2]
|
|
EVar x -> App "Var" [App (prCId x) []]
|
|
ELit (LStr s) -> AStr s
|
|
ELit (LFlt d) -> AFlt d
|
|
ELit (LInt i) -> AInt (toInteger i)
|
|
EMeta _ -> AMet ----
|
|
EEq eqs -> App "Eq" [App "E" (map fromExp (v:ps)) | Equ ps v <- eqs]
|
|
|
|
fromTerm :: Term -> RExp
|
|
fromTerm e = case e of
|
|
R es -> App "R" (map fromTerm es)
|
|
S es -> App "S" (map fromTerm es)
|
|
FV es -> App "FV" (map fromTerm es)
|
|
P e v -> App "P" [fromTerm e, fromTerm v]
|
|
W s v -> App "W" [AStr s, fromTerm v]
|
|
C i -> AInt (toInteger i)
|
|
TM _ -> AMet
|
|
F f -> App (prCId f) []
|
|
V i -> App "A" [AInt (toInteger i)]
|
|
K t -> fromTokn t
|
|
|
|
fromTokn :: Tokn -> RExp
|
|
fromTokn (KS s) = AStr s
|
|
fromTokn (KP d vs) = App "KP" (str d : [App "A" [str v, str x] | Alt v x <- vs])
|
|
where
|
|
str v = App "S" (map AStr v)
|
|
|
|
-- ** Parsing info
|
|
|
|
fromPInfo :: ParserInfo -> RExp
|
|
fromPInfo p = App "parser" [
|
|
App "functions" [fromFFun fun | fun <- elems (functions p)],
|
|
App "sequences" [fromFSeq seq | seq <- elems (sequences p)],
|
|
App "productions" [fromProductionSet xs | xs <- IntMap.toList (productions p)],
|
|
App "categories" (intToExp (totalCats p) : [App (prCId f) (map intToExp xs) | (f,xs) <- Map.toList (startCats p)])
|
|
]
|
|
|
|
fromFFun :: FFun -> RExp
|
|
fromFFun (FFun fun prof lins) = App (prCId fun) [App "P" (map fromProfile prof), App "R" [intToExp seqid | seqid <- elems lins]]
|
|
where
|
|
fromProfile :: Profile -> RExp
|
|
fromProfile [] = AMet
|
|
fromProfile [x] = daughter x
|
|
fromProfile args = App "_U" (map daughter args)
|
|
|
|
daughter n = App "_A" [intToExp n]
|
|
|
|
fromSymbol :: FSymbol -> RExp
|
|
fromSymbol (FSymCat n l) = App "P" [intToExp n, intToExp l]
|
|
fromSymbol (FSymTok t) = fromTokn t
|
|
|
|
fromFSeq :: FSeq -> RExp
|
|
fromFSeq seq = App "seq" [fromSymbol s | s <- elems seq]
|
|
|
|
fromProductionSet :: (FCat,Set.Set Production) -> RExp
|
|
fromProductionSet (cat,xs) = App "td" (intToExp cat : map fromPassive (Set.toList xs))
|
|
where
|
|
fromPassive (FApply ruleid args) = App "A" (intToExp ruleid : map intToExp args)
|
|
fromPassive (FCoerce fcat) = App "C" [intToExp fcat]
|
|
|
|
-- ** Utilities
|
|
|
|
mkTermMap :: [RExp] -> Map.Map CId Term
|
|
mkTermMap ts = Map.fromAscList [(mkCId f,toTerm v) | App f [v] <- ts]
|
|
|
|
mkArray :: IArray a e => [e] -> a Int e
|
|
mkArray xs = listArray (0, length xs - 1) xs
|
|
|
|
expToInt :: Integral a => RExp -> a
|
|
expToInt (App "neg" [AInt i]) = fromIntegral (negate i)
|
|
expToInt (AInt i) = fromIntegral i
|
|
|
|
expToStr :: RExp -> String
|
|
expToStr (AStr s) = s
|
|
|
|
intToExp :: Integral a => a -> RExp
|
|
intToExp x | x < 0 = App "neg" [AInt (fromIntegral (negate x))]
|
|
| otherwise = AInt (fromIntegral x)
|