mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 19:22:50 -06:00
224 lines
6.8 KiB
Haskell
224 lines
6.8 KiB
Haskell
module GF.Devel.Grammar.GFtoSource (
|
|
trGrammar,
|
|
trModule,
|
|
trAnyDef,
|
|
trLabel,
|
|
trt,
|
|
tri,
|
|
trp
|
|
) where
|
|
|
|
|
|
import GF.Devel.Grammar.Modules
|
|
import GF.Devel.Grammar.Judgements
|
|
import GF.Devel.Grammar.Terms
|
|
import GF.Devel.Grammar.Macros (contextOfType)
|
|
import qualified GF.Devel.Grammar.AbsGF as P
|
|
import GF.Infra.Ident
|
|
|
|
import GF.Data.Operations
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
-- From internal source syntax to BNFC-generated (used for printing).
|
|
-- | AR 13\/5\/2003
|
|
--
|
|
-- translate internal to parsable and printable source
|
|
|
|
trGrammar :: GF -> P.Grammar
|
|
trGrammar = P.Gr . map trModule . listModules -- no includes
|
|
|
|
trModule :: (Ident,Module) -> P.ModDef
|
|
trModule (i,mo) = P.MModule compl typ body where
|
|
compl = case isCompleteModule mo of
|
|
False -> P.CMIncompl
|
|
_ -> P.CMCompl
|
|
i' = tri i
|
|
typ = case mtype mo of
|
|
MTGrammar -> P.MGrammar i'
|
|
MTAbstract -> P.MAbstract i'
|
|
MTConcrete a -> P.MConcrete i' (tri a)
|
|
MTInterface -> P.MInterface i'
|
|
MTInstance a -> P.MInstance i' (tri a)
|
|
body = P.MBody
|
|
(trExtends (mextends mo))
|
|
(mkOpens (map trOpen (mopens mo)))
|
|
(concatMap trAnyDef [(c,j) | (c,Left j) <- listJudgements mo] ++
|
|
map trFlag (Map.assocs (mflags mo)))
|
|
|
|
trExtends :: [(Ident,MInclude)] -> P.Extend
|
|
trExtends [] = P.NoExt
|
|
trExtends es = (P.Ext $ map tre es) where
|
|
tre (i,c) = case c of
|
|
MIAll -> P.IAll (tri i)
|
|
MIOnly is -> P.ISome (tri i) (map tri is)
|
|
MIExcept is -> P.IMinus (tri i) (map tri is)
|
|
|
|
trOpen :: (Ident,Ident) -> P.Open
|
|
trOpen (i,j) = P.OQual (tri i) (tri j)
|
|
|
|
mkOpens ds = if null ds then P.NoOpens else P.OpenIn ds
|
|
|
|
trAnyDef :: (Ident,Judgement) -> [P.TopDef]
|
|
trAnyDef (i,ju) = let
|
|
i' = mkName i
|
|
i0 = tri i
|
|
in case jform ju of
|
|
JCat -> [P.DefCat [P.SimpleCatDef i0 []]] ---- (map trDecl co)]]
|
|
JFun -> [P.DefFun [P.FDecl [i'] (trt (jtype ju))]]
|
|
---- ++ case pt of
|
|
---- Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]]
|
|
---- _ -> []
|
|
---- JFun ty EData -> [P.DefFunData [P.FunDef [i'] (trt ty)]]
|
|
JParam -> [P.DefPar [
|
|
P.ParDefDir i0 [
|
|
P.ParConstr (tri c) (map trDecl co) |
|
|
(c,co) <- [(k,contextOfType t) | (k,t) <- contextOfType (jtype ju)]
|
|
]
|
|
]]
|
|
JOper -> case jdef ju of
|
|
Overload tysts ->
|
|
[P.DefOper [P.DDef [i'] (
|
|
P.EApp (P.EPIdent $ ppIdent "overload")
|
|
(P.ERecord [P.LDFull [i0] (trt ty) (trt fu) | (ty,fu) <- tysts]))]]
|
|
tr -> [P.DefOper [trDef i (jtype ju) tr]]
|
|
JLincat -> [P.DefLincat [P.DDef [i'] (trt (jtype ju))]]
|
|
---- CncCat pty ptr ppr ->
|
|
---- [P.DefLindef [trDef i' pty ptr]]
|
|
---- ++ [P.DefPrintCat [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
|
|
JLin ->
|
|
[P.DefLin [trDef i (Meta 0) (jdef ju)]]
|
|
---- ++ [P.DefPrintFun [P.DDef [mkName i] (trt pr)] | Yes pr <- [ppr]]
|
|
{-
|
|
---- encoding of AnyInd without changing syntax. AR 20/9/2007
|
|
AnyInd s b ->
|
|
[P.DefOper [P.DDef [mkName i]
|
|
(P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]]
|
|
-}
|
|
|
|
|
|
trDef :: Ident -> Type -> Term -> P.Def
|
|
trDef i pty ptr = case (pty,ptr) of
|
|
(Meta _, Meta _) -> P.DDef [mkName i] (P.EMeta) ---
|
|
(_, Meta _) -> P.DDecl [mkName i] (trPerh pty)
|
|
(Meta _, _) -> P.DDef [mkName i] (trPerh ptr)
|
|
(_, _) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr)
|
|
|
|
trPerh p = case p of
|
|
Meta _ -> P.EMeta
|
|
_ -> trt p
|
|
|
|
trFlag :: (Ident,String) -> P.TopDef
|
|
trFlag (f,x) = P.DefFlag [P.DDef [mkName f] (P.EString x)]
|
|
|
|
trt :: Term -> P.Exp
|
|
trt trm = case trm of
|
|
Vr s -> P.EPIdent $ tri s
|
|
---- Cn s -> P.ECons $ tri s
|
|
Con s -> P.EConstr $ tri s
|
|
Sort s -> P.ESort $ case s of
|
|
"Type" -> P.Sort_Type
|
|
"PType" -> P.Sort_PType
|
|
"Tok" -> P.Sort_Tok
|
|
"Str" -> P.Sort_Str
|
|
"Strs" -> P.Sort_Strs
|
|
_ -> error $ "not yet sort " +++ show trm ----
|
|
|
|
App c a -> P.EApp (trt c) (trt a)
|
|
Abs x b -> P.EAbstr [trb x] (trt b)
|
|
Eqs pts -> P.EEqs [P.Equ (map trp ps) (trt t) | (ps,t) <- pts]
|
|
Meta m -> P.EMeta
|
|
Prod x a b | isWildIdent x -> P.EProd (P.DExp (trt a)) (trt b)
|
|
Prod x a b -> P.EProd (P.DDec [trb x] (trt a)) (trt b)
|
|
|
|
Example t s -> P.EExample (trt t) s
|
|
R [] -> P.ETuple [] --- to get correct parsing when read back
|
|
R r -> P.ERecord $ map trAssign r
|
|
RecType r -> P.ERecord $ map trLabelling r
|
|
ExtR x y -> P.EExtend (trt x) (trt y)
|
|
P t l -> P.EProj (trt t) (trLabel l)
|
|
PI t l _ -> P.EProj (trt t) (trLabel l)
|
|
Q t l -> P.EQCons (tri t) (tri l)
|
|
QC t l -> P.EQConstr (tri t) (tri l)
|
|
T (TTyped ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
|
T (TComp ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
|
T (TWild ty) cc -> P.ETTable (trt ty) (map trCase cc)
|
|
T _ cc -> P.ETable (map trCase cc)
|
|
V ty cc -> P.EVTable (trt ty) (map trt cc)
|
|
|
|
Table x v -> P.ETType (trt x) (trt v)
|
|
S f x -> P.ESelect (trt f) (trt x)
|
|
Let (x,(ma,b)) t ->
|
|
P.ELet [maybe (P.LDDef x' b') (\ty -> P.LDFull x' (trt ty) b') ma] (trt t)
|
|
where
|
|
b' = trt b
|
|
x' = [tri x]
|
|
Empty -> P.EEmpty
|
|
K [] -> P.EEmpty
|
|
K a -> P.EString a
|
|
C a b -> P.EConcat (trt a) (trt b)
|
|
|
|
EInt i -> P.EInt i
|
|
EFloat i -> P.EFloat i
|
|
|
|
Glue a b -> P.EGlue (trt a) (trt b)
|
|
Alts (t, tt) -> P.EPre (trt t) [P.Alt (trt v) (trt c) | (v,c) <- tt]
|
|
FV ts -> P.EVariants $ map trt ts
|
|
EData -> P.EData
|
|
_ -> error $ "not yet" +++ show trm ----
|
|
|
|
trp :: Patt -> P.Patt
|
|
trp p = case p of
|
|
PW -> P.PW
|
|
PV s | isWildIdent s -> P.PW
|
|
PV s -> P.PV $ tri s
|
|
PC c [] -> P.PCon $ tri c
|
|
PC c a -> P.PC (tri c) (map trp a)
|
|
PP p c [] -> P.PQ (tri p) (tri c)
|
|
PP p c a -> P.PQC (tri p) (tri c) (map trp a)
|
|
PR r -> P.PR [P.PA [trLabelIdent l] (trp p) | (l,p) <- r]
|
|
PString s -> P.PStr s
|
|
PInt i -> P.PInt i
|
|
PFloat i -> P.PFloat i
|
|
PT t p -> trp p ---- prParenth (prt p +++ ":" +++ prt t)
|
|
|
|
PAs x p -> P.PAs (tri x) (trp p)
|
|
|
|
PAlt p q -> P.PDisj (trp p) (trp q)
|
|
PSeq p q -> P.PSeq (trp p) (trp q)
|
|
PRep p -> P.PRep (trp p)
|
|
PNeg p -> P.PNeg (trp p)
|
|
|
|
|
|
trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t') mty
|
|
where
|
|
t' = trt t
|
|
x = [trLabelIdent lab]
|
|
|
|
trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
|
|
|
|
trCase (patt, trm) = P.Case (trp patt) (trt trm)
|
|
trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
|
|
|
|
trDecl (x,ty) = P.DDDec [trb x] (trt ty)
|
|
|
|
tri :: Ident -> P.PIdent
|
|
tri i = ppIdent (prIdent i)
|
|
|
|
ppIdent i = P.PIdent ((0,0),i)
|
|
|
|
trb i = if isWildIdent i then P.BWild else P.BPIdent (tri i)
|
|
|
|
trLabel :: Label -> P.Label
|
|
trLabel i = case i of
|
|
LIdent s -> P.LPIdent $ ppIdent s
|
|
LVar i -> P.LVar $ toInteger i
|
|
|
|
trLabelIdent i = ppIdent $ case i of
|
|
LIdent s -> s
|
|
LVar i -> "v" ++ show i --- should not happen
|
|
|
|
mkName :: Ident -> P.Name
|
|
mkName = P.PIdentName . tri
|
|
|