mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-16 22:52:50 -06:00
PGF.Type.Hypo now can represent explicit and implicit arguments and argument without bound variable
This commit is contained in:
@@ -69,11 +69,11 @@ plCat :: (CId, [Hypo]) -> String
|
||||
plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
|
||||
where ((_,subst), hypos') = alphaConvert emptyEnv hypos
|
||||
args = reverse [EVar x | (_,x) <- subst]
|
||||
typ = wildcardUnusedVars $ DTyp hypos' cat args
|
||||
typ = DTyp hypos' cat args
|
||||
|
||||
plFun :: (CId, (Type, Int, [Equation])) -> String
|
||||
plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
|
||||
where typ' = wildcardUnusedVars $ snd $ alphaConvert emptyEnv typ
|
||||
where typ' = snd $ alphaConvert emptyEnv typ
|
||||
|
||||
plTypeWithHypos :: Type -> [String]
|
||||
plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plp hypos]
|
||||
@@ -114,7 +114,9 @@ instance PLPrint Type where
|
||||
where result = plTerm (plp cat) (map plp args)
|
||||
|
||||
instance PLPrint Hypo where
|
||||
plp (Hyp var typ) = plOper ":" (plp var) (plp typ)
|
||||
plp (Hyp typ) = plOper ":" (plp wildCId) (plp typ)
|
||||
plp (HypI var typ) = plOper ":" (plp var) (plp typ)
|
||||
plp (HypV var typ) = plOper ":" (plp var) (plp typ)
|
||||
|
||||
instance PLPrint Expr where
|
||||
plp (EVar x) = plp x
|
||||
@@ -261,7 +263,12 @@ instance AlphaConvert Type where
|
||||
((ctr,_), args') = alphaConvert env' args
|
||||
|
||||
instance AlphaConvert Hypo where
|
||||
alphaConvert env (Hyp x typ) = ((ctr+1,(x,x'):subst), Hyp x' typ')
|
||||
alphaConvert env (Hyp typ) = ((ctr+1,subst), Hyp typ')
|
||||
where ((ctr,subst), typ') = alphaConvert env typ
|
||||
alphaConvert env (HypI x typ) = ((ctr+1,(x,x'):subst), HypI x' typ')
|
||||
where ((ctr,subst), typ') = alphaConvert env typ
|
||||
x' = createLogicalVariable ctr
|
||||
alphaConvert env (HypV x typ) = ((ctr+1,(x,x'):subst), HypV x' typ')
|
||||
where ((ctr,subst), typ') = alphaConvert env typ
|
||||
x' = createLogicalVariable ctr
|
||||
|
||||
@@ -281,21 +288,3 @@ instance AlphaConvert Equation where
|
||||
alphaConvert env@(_,subst) (Equ patterns result)
|
||||
= ((ctr,subst), Equ patterns result')
|
||||
where ((ctr,_), result') = alphaConvert env result
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- translate unused variables to wildcards
|
||||
|
||||
wildcardUnusedVars :: Type -> Type
|
||||
wildcardUnusedVars typ@(DTyp hypos cat args) = DTyp hypos' cat args
|
||||
where hypos' = [Hyp x' (wildcardUnusedVars typ') |
|
||||
Hyp x typ' <- hypos,
|
||||
let x' = if unusedInType x typ then wildCId else x]
|
||||
|
||||
unusedInType x (DTyp hypos _cat args)
|
||||
= and [unusedInType x typ | Hyp _ typ <- hypos] &&
|
||||
and [unusedInExpr x exp | exp <- args]
|
||||
|
||||
unusedInExpr x (EAbs y e) = unusedInExpr x e
|
||||
unusedInExpr x (EApp e e') = unusedInExpr x e && unusedInExpr x e'
|
||||
unusedInExpr x (EVar y) = x/=y
|
||||
unusedInExpr x expr = True
|
||||
|
||||
@@ -371,8 +371,9 @@ expandHOAS abs_defs cnc_defs lincats env =
|
||||
|
||||
hoCats :: [CId]
|
||||
hoCats = sortNub [c | (_,(ty,_,_)) <- abs_defs
|
||||
, Hyp _ ty <- case ty of {DTyp hyps val _ -> hyps}
|
||||
, c <- fst (catSkeleton ty)]
|
||||
, h <- case ty of {DTyp hyps val _ -> hyps}
|
||||
, let ty = typeOfHypo h
|
||||
, c <- fst (catSkeleton ty)]
|
||||
|
||||
-- add a range of PMCFG categories for each GF high-order category
|
||||
add_hoCat env@(GrammarEnv last_id catSet seqSet funSet crcSet prodSet) (n,cat) =
|
||||
|
||||
@@ -147,7 +147,7 @@ mkPatt p = case p of
|
||||
|
||||
|
||||
mkContext :: A.Context -> [C.Hypo]
|
||||
mkContext hyps = [C.Hyp (i2i x) (mkType ty) | (x,ty) <- hyps]
|
||||
mkContext hyps = [(if x == identW then C.Hyp else C.HypV (i2i x)) (mkType ty) | (x,ty) <- hyps]
|
||||
|
||||
mkTerm :: Term -> C.Term
|
||||
mkTerm tr = case tr of
|
||||
|
||||
Reference in New Issue
Block a user