msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Expose GF.Grammar.Canonical + some refactoring

Browse Source 
to make it available in other tools by depending on the gf package and
importing it
This commit is contained in:
Thomas Hallgren
2019-03-07 17:41:16 +01:00
parent b783299b73
commit 5b401f3880
6 changed files with 105 additions and 53 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -142,8 +142,8 @@ concrete2haskell opts
rhs = lets (zipWith letlin args absctx)
(convert vs (coerce env lincat rhs0))
where
vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args]
env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
@@ -173,15 +173,20 @@ concrete2haskell opts
VariantValue [] -> empty
VariantValue ts@(_:_) -> variants ts
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
PreValue vs t' -> pure (alts t' vs)
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
LiteralValue l -> ppL l
_ -> error ("convert "++show t)
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
@@ -329,7 +334,7 @@ coerce env ty t =
_ -> t
where
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . to_rcon' . labels
to_rcon = ParamId . Unqual . to_rcon' . labels
patVars p = []
@@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId s) = identS s
instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
instance ToIdent PredefId where toIdent (PredefId s) = identS s
instance ToIdent CatId where toIdent (CatId s) = identS s
instance ToIdent C.FunId where toIdent (FunId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId s) = identS s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
qIdentS = identS . unqual
unqual (Qual (ModId m) n) = m++"_"++n
unqual (Unqual n) = n
instance ToIdent VarId where
toIdent Anonymous = identW

46
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -165,11 +165,11 @@ convert' gr vs = ppT
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> IntConstant n
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n))
QC (m,n) -> ParamConstant (Param (gId (qual m n)) [])
K s -> StrConstant s
Empty -> StrConstant ""
EInt n -> LiteralValue (IntConstant n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' "++show t
@@ -183,14 +183,14 @@ convert' gr vs = ppT
Ok SOFT_SPACE -> p "SOFT_SPACE"
Ok CAPIT -> p "CAPIT"
Ok ALL_CAPIT -> p "ALL_CAPIT"
_ -> VarValue (gId n)
_ -> VarValue (gQId cPredef n) -- hmm
where
p = PredefValue . PredefId
ppP p =
case p of
PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param (gId (qual m c)) (map ppP ps))
PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
PR r -> RecordPattern (fields r) {-
PW -> WildPattern
PV x -> VarP x
@@ -233,8 +233,8 @@ convert' gr vs = ppT
concatValue v1 v2 =
case (v1,v2) of
(StrConstant "",_) -> v2
(_,StrConstant "") -> v1
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
_ -> ConcatValue v1 v2
projection r l = maybe (Projection r l) id (proj r l)
@@ -298,8 +298,8 @@ convType = ppT
Sort k -> convSort k
-- EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
FV (t:ts) -> ppT t -- !!
QC (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
Q (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
_ -> error $ "Missing case in convType for: "++show t
convFields = map convField . filter (not.isLockLabel.fst)
@@ -325,25 +325,21 @@ paramType gr q@(_,n) =
((S.singleton (m,n),argTypes ps),
[ParamDef name (map (param m) ps)]
)
where name = gId (qual m n)
where name = (gQId m n)
Ok (m,ResOper _ (Just (L _ t)))
| m==cPredef && n==cInts ->
((S.empty,S.empty),[]) {-
((S.singleton (m,n),S.empty),
[Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-}
[Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
| otherwise ->
((S.singleton (m,n),paramTypes gr t),
[ParamAliasDef (gId (qual m n)) (convType t)])
[ParamAliasDef ((gQId m n)) (convType t)])
_ -> ((S.empty,S.empty),[])
where
param m (n,ctx) = Param (gId (qual m n)) [toParamId t|(_,_,t)<-ctx]
param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
qual :: ModuleName -> Ident -> Ident
qual m = prefixIdent (render m++"_")
lblId = LabelId . render -- hmm
modId (MN m) = ModId (showIdent m)
@@ -354,8 +350,16 @@ instance FromIdent VarId where
instance FromIdent C.FunId where gId = C.FunId . showIdent
instance FromIdent CatId where gId = CatId . showIdent
instance FromIdent ParamId where gId = ParamId . showIdent
instance FromIdent VarValueId where gId = VarValueId . showIdent
instance FromIdent ParamId where gId = ParamId . unqual
instance FromIdent VarValueId where gId = VarValueId . unqual
class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
instance QualIdent ParamId where gQId m n = ParamId (qual m n)
instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
qual m n = Qual (modId m) (showIdent n)
unqual n = Unqual (showIdent n)
convFlags gr mn =
Flags [(n,convLit v) |