Commit 6bc0c710 authored by marton bognar's avatar marton bognar
Browse files

Use updated FCo and Fi+ specifications for their implementation

parent 771b759b
module Elaborate
( Term(..)
, Type(..)
, Coercion(..)
, elaborate
, goodelaborate
) where
module Elaborate where
import Fi
import FiImpl
import FCoBase
import qualified FiPlusBase as FP
import qualified FiImpl as FIm
data Term
= TmVarCo HNat
| TmAbsCo Term
Type
| TmAppCo Term
Term
| TmTAppCo Term
Type
| TmTAbsCo Term
| TmTopCo
| TmTupleCo Term
Term
| TmIntCo Int
| TmCast Coercion
Term
deriving (Show, Eq)
varTranslate :: FP.Variable -> Variable
varTranslate FP.Z = Z
varTranslate (FP.STermVar var) = STermVar (varTranslate var)
varTranslate (FP.STypeVar var) = STypeVar (varTranslate var)
data Type
= TyVarCo HNat
| TyArrCo Type
Type
| TyAllCo Type
| TyIntCo
| TyTopCo
| TyProdCo Type
Type
deriving (Show, Eq)
getTypeFromEnv :: FIm.Env -> FP.Variable -> Either String FP.FiType
getTypeFromEnv (FIm.ETermVar ty _) FP.Z = return ty
getTypeFromEnv _ FP.Z = Left "wrong or no binding for FiTerm"
getTypeFromEnv (FIm.ETermVar _ rest) (FP.STermVar h) = getTypeFromEnv rest h
getTypeFromEnv _ (FP.STermVar h) = Left "wrong FiTerm binding"
getTypeFromEnv (FIm.ETypeVar _ rest) (FP.STypeVar h) = getTypeFromEnv rest h
getTypeFromEnv _ (FP.STypeVar h) = Left "No variable FP.FiType"
data Coercion
= CoId
| CoTrans Coercion
Coercion
| CoTop
| CoBot
| CoArrow Coercion
Coercion
| CoTuple Coercion
Coercion
| CoProj1
| CoProj2
| CoAll Coercion
| CoDistArrow
| CoTopArrow
| CoTopAll
| CoDistAll
deriving (Show, Eq)
getTypeFromEnv :: Env -> HNat -> Either String FiType
getTypeFromEnv (ETermVar ty _) Z = return ty
getTypeFromEnv _ Z = Left "wrong or no binding for FiTerm"
getTypeFromEnv (ETermVar _ rest) (STermVar h) = getTypeFromEnv rest h
getTypeFromEnv _ (STermVar h) = Left "wrong FiTerm binding"
getTypeFromEnv (ETypeVar _ rest) (STypeVar h) = getTypeFromEnv rest h
getTypeFromEnv _ (STypeVar h) = Left "No variable FiType"
elaborate :: FiTerm -> Env -> Either String Term
elaborate TmTop ctx = return TmTopCo
elaborate (TmInt i) ctx = return (TmIntCo i)
elaborate (TmVar hnat) ctx = return (TmVarCo hnat)
elaborate (TmAbs t ty) ctx = do
term <- elaborate t (ETermVar ty ctx)
return (TmAbsCo term (convertType ty))
elaborate (TmApp t1 t2) ctx = do
elaborate :: FP.FiTerm -> FIm.Env -> Either String Term
elaborate FP.TmTop ctx = return TmTop
elaborate (FP.TmInt i) ctx = return (TmInt i)
elaborate (FP.TmVar hnat) ctx = return (TmVar (varTranslate hnat))
elaborate (FP.TmAbs t ty) ctx = do
term <- elaborate t (FIm.ETermVar ty ctx)
return (TmAbs term (convertType ty))
elaborate (FP.TmApp t1 t2) ctx = do
term1 <- elaborate t1 ctx
term2 <- elaborate t2 ctx
ty2 <- typeOf t2 ctx
case typeOf t1 ctx of
Right (TyArr ty3 ty4) -> do
a <- (algoSubtypingCo EmptyQueue ty2 ty3)
return (TmAppCo term1 (TmCast a term2))
ty2 <- FIm.typeOf t2 ctx
case FIm.typeOf t1 ctx of
Right (FP.TyArr ty3 ty4) -> do
a <- (algoSubtypingCo FIm.EmptyQueue ty2 ty3)
return (TmApp term1 (TmCast a term2))
_ -> Left "Wrong use of elaborate"
elaborate (TmMerge t1 t2) ctx = do
elaborate (FP.TmMerge t1 t2) ctx = do
term1 <- elaborate t1 ctx
term2 <- elaborate t2 ctx
return (TmTupleCo term1 term2)
elaborate (TmRecord t str) ctx = do
return (TmTuple term1 term2)
elaborate (FP.TmRecord t str) ctx = do
term <- elaborate t ctx
return term
elaborate (TmProj t str) ctx = do
elaborate (FP.TmProj t str) ctx = do
term <- elaborate t ctx
return term
elaborate (TmAnn t ty) ctx = do
tyt <- typeOf t ctx
elaborate (FP.TmAnn t ty) ctx = do
tyt <- FIm.typeOf t ctx
term <- elaborate t ctx
sub <- (algoSubtypingCo EmptyQueue tyt ty)
sub <- (algoSubtypingCo FIm.EmptyQueue tyt ty)
return (TmCast sub term)
elaborate (TypeApp t ty) ctx = do
elaborate (FP.TypeApp t ty) ctx = do
term <- elaborate t ctx
return (TmTAppCo term (convertType ty))
elaborate (TmAll ty t) ctx = do
term <- elaborate t (ETypeVar ty ctx)
return (TmTAbsCo term)
return (TmTApp term (convertType ty))
elaborate (FP.TmAll ty t) ctx = do
term <- elaborate t (FIm.ETypeVar ty ctx)
return (TmTAbs term)
convertType :: FiType -> Type
convertType TyInt = TyIntCo
convertType (TyAnd ty1 ty2) = TyProdCo (convertType ty1) (convertType ty2)
convertType TyBot = TyAllCo (TyVarCo Z)
convertType TyTop = TyTopCo
convertType (TyRecord ty _) = convertType ty
convertType (TyVar hnat) = TyVarCo hnat
convertType (TyArr ty1 ty2) = TyArrCo (convertType ty1) (convertType ty2)
convertType (TyAll ty tyB) = TyAllCo (convertType tyB)
convertType :: FP.FiType -> Type
convertType FP.TyInt = TyInt
convertType (FP.TyAnd ty1 ty2) = TyProd (convertType ty1) (convertType ty2)
convertType FP.TyBot = TyAll (TyVar Z)
convertType FP.TyTop = TyTop
convertType (FP.TyRecord ty _) = convertType ty
convertType (FP.TyVar hnat) = TyVar (varTranslate hnat)
convertType (FP.TyArr ty1 ty2) = TyArr (convertType ty1) (convertType ty2)
convertType (FP.TyAll ty tyB) = TyAll (convertType tyB)
pushQueue :: Queue -> Queue -> Queue
pushQueue EmptyQueue q = q
pushQueue (LabelQueue str q) newq = LabelQueue str (pushQueue q newq)
pushQueue (TypeQueue ty q) newq = TypeQueue ty (pushQueue q newq)
pushQueue (TypeStarQueue ty q) newq = TypeStarQueue ty (pushQueue q newq)
pushQueue :: FIm.Queue -> FIm.Queue -> FIm.Queue
pushQueue FIm.EmptyQueue q = q
pushQueue (FIm.LabelQueue str q) newq = FIm.LabelQueue str (pushQueue q newq)
pushQueue (FIm.TypeQueue ty q) newq = FIm.TypeQueue ty (pushQueue q newq)
pushQueue (FIm.TypeStarQueue ty q) newq = FIm.TypeStarQueue ty (pushQueue q newq)
isTypeConstant :: FiType -> Bool
isTypeConstant TyInt = True
isTypeConstant TyBot = True
isTypeConstant (TyVar _) = True
isTypeConstant :: FP.FiType -> Bool
isTypeConstant FP.TyInt = True
isTypeConstant FP.TyBot = True
isTypeConstant (FP.TyVar _) = True
isTypeConstant _ = False
algoSubtypingCo :: Queue -> FiType -> FiType -> Either String Coercion
algoSubtypingCo q tyA TyTop = do
algoSubtypingCo :: FIm.Queue -> FP.FiType -> FP.FiType -> Either String Coercion
algoSubtypingCo q tyA FP.TyTop = do
a <- (calcQueueTop q)
return (CoTrans a (CoTop))
algoSubtypingCo q tyA (TyAnd ty1 ty2) = do
algoSubtypingCo q tyA (FP.TyAnd ty1 ty2) = do
a <- (algoSubtypingCo q tyA ty1)
b <- (algoSubtypingCo q tyA ty2)
c <- (calcQueueAnd q)
return (CoTrans c (CoTuple a b))
algoSubtypingCo q tyA (TyArr ty1 ty2) =
algoSubtypingCo (pushQueue q (TypeQueue ty1 EmptyQueue)) tyA ty2
algoSubtypingCo EmptyQueue tyA tyB
algoSubtypingCo q tyA (FP.TyArr ty1 ty2) =
algoSubtypingCo (pushQueue q (FIm.TypeQueue ty1 FIm.EmptyQueue)) tyA ty2
algoSubtypingCo FIm.EmptyQueue tyA tyB
| tyA == tyB && isTypeConstant tyA = return CoId
algoSubtypingCo q TyBot c
algoSubtypingCo q FP.TyBot c
| isTypeConstant c = return CoBot
algoSubtypingCo q tyA (TyRecord tyB str) =
algoSubtypingCo (pushQueue q (LabelQueue str EmptyQueue)) tyA tyB
algoSubtypingCo q tyA (TyAll ty1 ty2) =
algoSubtypingCo (pushQueue q (TypeStarQueue ty1 EmptyQueue)) tyA ty2
algoSubtypingCo (TypeQueue ty q) (TyArr ty1 ty2) tyB
algoSubtypingCo q tyA (FP.TyRecord tyB str) =
algoSubtypingCo (pushQueue q (FIm.LabelQueue str FIm.EmptyQueue)) tyA tyB
algoSubtypingCo q tyA (FP.TyAll ty1 ty2) =
algoSubtypingCo (pushQueue q (FIm.TypeStarQueue ty1 FIm.EmptyQueue)) tyA ty2
algoSubtypingCo (FIm.TypeQueue ty q) (FP.TyArr ty1 ty2) tyB
| isTypeConstant tyB = do
a <- (algoSubtypingCo EmptyQueue ty ty1)
a <- (algoSubtypingCo FIm.EmptyQueue ty ty1)
b <- (algoSubtypingCo q ty2 tyB)
return (CoArrow a b)
algoSubtypingCo (LabelQueue str1 q) (TyRecord ty2 str2) tyB
algoSubtypingCo (FIm.LabelQueue str1 q) (FP.TyRecord ty2 str2) tyB
| isTypeConstant tyB && str1 == str2 = algoSubtypingCo q ty2 tyB
algoSubtypingCo q (TyAnd ty1 ty2) tyB
| isTypeConstant tyB && algoSubtyping q ty1 tyB = do
algoSubtypingCo q (FP.TyAnd ty1 ty2) tyB
| isTypeConstant tyB && FIm.algoSubtyping q ty1 tyB = do
a <- (algoSubtypingCo q ty1 tyB)
return (CoTrans a (CoProj1))
| isTypeConstant tyB && algoSubtyping q ty2 tyB = do
| isTypeConstant tyB && FIm.algoSubtyping q ty2 tyB = do
a <- (algoSubtypingCo q ty2 tyB)
return (CoTrans a (CoProj2))
algoSubtypingCo (TypeStarQueue ty q) (TyAll ty1 ty2) tyB
algoSubtypingCo (FIm.TypeStarQueue ty q) (FP.TyAll ty1 ty2) tyB
| isTypeConstant tyB = do
a <- (algoSubtypingCo q ty2 tyB)
return (CoAll a)
algoSubtypingCo _ _ _ = Left "no subtype"
calcQueueTop :: Queue -> Either String Coercion
calcQueueTop EmptyQueue = return CoTop
calcQueueTop (LabelQueue _ q) = do
calcQueueTop :: FIm.Queue -> Either String Coercion
calcQueueTop FIm.EmptyQueue = return CoTop
calcQueueTop (FIm.LabelQueue _ q) = do
a <- (calcQueueTop q)
return (CoTrans a CoId)
calcQueueTop (TypeQueue _ q) = do
calcQueueTop (FIm.TypeQueue _ q) = do
a <- (calcQueueTop q)
return (CoTrans (CoArrow CoTop a) CoTopArrow)
calcQueueTop (TypeStarQueue _ q) = do
calcQueueTop (FIm.TypeStarQueue _ q) = do
a <- (calcQueueTop q)
return (CoTrans (CoAll a) CoTopAll)
calcQueueAnd :: Queue -> Either String Coercion
calcQueueAnd EmptyQueue = return CoTop
calcQueueAnd (LabelQueue _ q) = do
calcQueueAnd :: FIm.Queue -> Either String Coercion
calcQueueAnd FIm.EmptyQueue = return CoTop
calcQueueAnd (FIm.LabelQueue _ q) = do
a <- (calcQueueAnd q)
return (CoTrans a CoId)
calcQueueAnd (TypeQueue _ q) = do
calcQueueAnd (FIm.TypeQueue _ q) = do
a <- (calcQueueAnd q)
return (CoTrans (CoArrow CoId a) CoDistArrow)
calcQueueAnd (TypeStarQueue _ q) = do
calcQueueAnd (FIm.TypeStarQueue _ q) = do
a <- (calcQueueAnd q)
return (CoTrans (CoAll a) CoDistAll)
goodelaborate term = do
ty <- typeOf term Nil
elaborate term Nil
ty <- FIm.typeOf term FIm.Nil
elaborate term FIm.Nil
module FCO
( Env(..)
, HNat(..)
, Coercion(..)
, coerciontypeSubstitute
, freeVariablesCoercion
, coercionshiftplus
, coercionshiftminus
, Type(..)
, typetypeSubstitute
, freeVariablesType
, typeshiftplus
, typeshiftminus
, Term(..)
, termtermSubstitute
, termtypeSubstitute
, freeVariablesTerm
, termshiftplus
, termshiftminus
, generateHnatTypeVar
, generateHnatTermVar
) where
import Data.List
data Coercion
= CoId
| CoTrans Coercion
Coercion
| CoTop Type
| CoBot Type
| CoArrow Coercion
Coercion
| CoTuple Coercion
Coercion
| CoProj1 Type
| CoProj2 Type
| CoAll Coercion
| CoDistArrow
| CoTopArrow
| CoTopAll
| CoDistAll
deriving (Show, Eq)
data Type
= TyVar HNat
| TyArr Type
Type
| TyAll Type
| TyInt
| TyTop
| TyProd Type
Type
deriving (Show, Eq)
data Term
= TmVar HNat
| TmAbs Term
Type
| TmApp Term
Term
| TmTApp Term
Type
| TmTAbs Term
| TmTop
| TmTuple Term
Term
| TmInt Int
| TmCast Coercion
Term
deriving (Show, Eq)
data HNat
= Z
| STypeVar HNat
| STermVar HNat
deriving (Show, Eq)
plus x1 (STypeVar x2) = STypeVar (plus x1 x2)
plus x1 (STermVar x2) = STermVar (plus x1 x2)
plus Z h = h
plus h Z = h
instance Ord HNat where
compare (STypeVar h1) (STypeVar h2) = compare h1 h2
compare (STypeVar h1) (STermVar h2) =
error "differing namespace found in compare "
compare (STermVar h1) (STypeVar h2) =
error "differing namespace found in compare "
compare (STermVar h1) (STermVar h2) = compare h1 h2
compare Z Z = EQ
compare Z _ = LT
compare _ Z = GT
minus (STypeVar h1) (STypeVar h2) = minus h1 h2
minus (STypeVar h1) (STermVar h2) = error "differing namespace found in minus "
minus (STermVar h1) (STypeVar h2) = error "differing namespace found in minus "
minus (STermVar h1) (STermVar h2) = minus h1 h2
minus Z Z = Z
minus Z _ = error " You cannot substract zero with a positive number "
minus result Z = result
data Env
= Nil
| ETypeVar Env
| ETermVar Type
Env
deriving (Show, Eq)
generateHnatTypeVar 0 c = c
generateHnatTypeVar n c = STypeVar (generateHnatTypeVar (n - 1) c)
generateHnatTermVar 0 c = c
generateHnatTermVar n c = STermVar (generateHnatTermVar (n - 1) c)
coercionmap :: (HNat -> Type -> Type) -> HNat -> Coercion -> Coercion
coercionmap onTypeVar c (CoId) = CoId
coercionmap onTypeVar c (CoTrans co1 co2) =
CoTrans (coercionmap onTypeVar c co1) (coercionmap onTypeVar c co2)
coercionmap onTypeVar c (CoTop ty) = CoTop (typemap onTypeVar c ty)
coercionmap onTypeVar c (CoBot ty) = CoBot (typemap onTypeVar c ty)
coercionmap onTypeVar c (CoArrow co1 co2) =
CoArrow (coercionmap onTypeVar c co1) (coercionmap onTypeVar c co2)
coercionmap onTypeVar c (CoTuple co1 co2) =
CoTuple (coercionmap onTypeVar c co1) (coercionmap onTypeVar c co2)
coercionmap onTypeVar c (CoProj1 ty2) = CoProj1 (typemap onTypeVar c ty2)
coercionmap onTypeVar c (CoProj2 ty1) = CoProj2 (typemap onTypeVar c ty1)
coercionmap onTypeVar c (CoAll co1) = CoAll (coercionmap onTypeVar c co1)
coercionmap onTypeVar c (CoDistArrow) = CoDistArrow
coercionmap onTypeVar c (CoTopArrow) = CoTopArrow
coercionmap onTypeVar c (CoTopAll) = CoTopAll
coercionmap onTypeVar c (CoDistAll) = CoDistAll
typemap :: (HNat -> Type -> Type) -> HNat -> Type -> Type
typemap onTypeVar c (TyVar hnat) = onTypeVar c (TyVar hnat)
typemap onTypeVar c (TyArr t1 t2) =
TyArr (typemap onTypeVar c t1) (typemap onTypeVar c t2)
typemap onTypeVar c (TyAll t1) = TyAll (typemap onTypeVar (STypeVar c) t1)
typemap onTypeVar c (TyInt) = TyInt
typemap onTypeVar c (TyTop) = TyTop
typemap onTypeVar c (TyProd t1 t2) =
TyProd (typemap onTypeVar c t1) (typemap onTypeVar c t2)
termmap ::
(HNat -> Term -> Term) -> (HNat -> Type -> Type) -> HNat -> Term -> Term
termmap onTermVar onTypeVar c (TmVar hnat) = onTermVar c (TmVar hnat)
termmap onTermVar onTypeVar c (TmAbs x t) =
TmAbs (termmap onTermVar onTypeVar (STermVar c) x) (typemap onTypeVar c t)
termmap onTermVar onTypeVar c (TmApp t1 t2) =
TmApp (termmap onTermVar onTypeVar c t1) (termmap onTermVar onTypeVar c t2)
termmap onTermVar onTypeVar c (TmTApp t1 t) =
TmTApp (termmap onTermVar onTypeVar c t1) (typemap onTypeVar c t)
termmap onTermVar onTypeVar c (TmTAbs t1) =
TmTAbs (termmap onTermVar onTypeVar (STypeVar c) t1)
termmap onTermVar onTypeVar c (TmTop) = TmTop
termmap onTermVar onTypeVar c (TmTuple e1 e2) =
TmTuple (termmap onTermVar onTypeVar c e1) (termmap onTermVar onTypeVar c e2)
termmap onTermVar onTypeVar c (TmInt int0) = TmInt int0
termmap onTermVar onTypeVar c (TmCast co e) =
TmCast (coercionmap onTypeVar c co) (termmap onTermVar onTypeVar c e)
typeshiftHelpplus d c (TyVar hnat)
| hnat >= c = TyVar (plus hnat d)
| otherwise = TyVar hnat
termshiftHelpplus d c (TmVar hnat)
| hnat >= c = TmVar (plus hnat d)
| otherwise = TmVar hnat
coercionshiftplus :: HNat -> Coercion -> Coercion
coercionshiftplus d t = coercionmap (typeshiftHelpplus d) Z t
typeshiftplus :: HNat -> Type -> Type
typeshiftplus d t = typemap (typeshiftHelpplus d) Z t
termshiftplus :: HNat -> Term -> Term
termshiftplus d t = termmap (termshiftHelpplus d) (typeshiftHelpplus d) Z t
typeshiftHelpminus d c (TyVar hnat)
| hnat >= c = TyVar (minus hnat d)
| otherwise = TyVar hnat
termshiftHelpminus d c (TmVar hnat)
| hnat >= c = TmVar (minus hnat d)
| otherwise = TmVar hnat
coercionshiftminus :: HNat -> Coercion -> Coercion
coercionshiftminus d t = coercionmap (typeshiftHelpminus d) Z t
typeshiftminus :: HNat -> Type -> Type
typeshiftminus d t = typemap (typeshiftHelpminus d) Z t
termshiftminus :: HNat -> Term -> Term
termshiftminus d t = termmap (termshiftHelpminus d) (typeshiftHelpminus d) Z t
typeSubstituteHelp sub orig c (TyVar hnat)
| hnat == plus orig c = typeshiftplus c sub
| otherwise = TyVar hnat
termSubstituteHelp sub orig c (TmVar hnat)
| hnat == plus orig c = termshiftplus c sub
| otherwise = TmVar hnat
coerciontypeSubstitute :: Type -> HNat -> Coercion -> Coercion
coerciontypeSubstitute sub orig t =
coercionmap (typeSubstituteHelp sub orig) Z t
typetypeSubstitute :: Type -> HNat -> Type -> Type
typetypeSubstitute sub orig t = typemap (typeSubstituteHelp sub orig) Z t
termtermSubstitute :: Term -> HNat -> Term -> Term
termtermSubstitute sub orig t =
termmap (termSubstituteHelp sub orig) (\c x -> x) Z t
termtypeSubstitute :: Type -> HNat -> Term -> Term
termtypeSubstitute sub orig t =
termmap (\c x -> x) (typeSubstituteHelp sub orig) Z t
freeVariablesCoercion :: HNat -> Coercion -> [HNat]
freeVariablesCoercion c (CoId) = nub ([])
freeVariablesCoercion c (CoTrans co1 co2) =
nub ((freeVariablesCoercion c co1) ++ (freeVariablesCoercion c co2))
freeVariablesCoercion c (CoTop ty) = nub ((freeVariablesType c ty))
freeVariablesCoercion c (CoBot ty) = nub ((freeVariablesType c ty))
freeVariablesCoercion c (CoArrow co1 co2) =
nub ((freeVariablesCoercion c co1) ++ (freeVariablesCoercion c co2))
freeVariablesCoercion c (CoTuple co1 co2) =
nub ((freeVariablesCoercion c co1) ++ (freeVariablesCoercion c co2))
freeVariablesCoercion c (CoProj1 ty2) = nub ((freeVariablesType c ty2))
freeVariablesCoercion c (CoProj2 ty1) = nub ((freeVariablesType c ty1))
freeVariablesCoercion c (CoAll co1) = nub ((freeVariablesCoercion c co1))
freeVariablesCoercion c (CoDistArrow) = nub ([])
freeVariablesCoercion c (CoTopArrow) = nub ([])
freeVariablesCoercion c (CoTopAll) = nub ([])
freeVariablesCoercion c (CoDistAll) = nub ([])
freeVariablesType :: HNat -> Type -> [HNat]
freeVariablesType c (TyVar hnat)
| hnat >= c = [minus hnat c]
| otherwise = []
freeVariablesType c (TyArr t1 t2) =
nub ((freeVariablesType c t1) ++ (freeVariablesType c t2))
freeVariablesType c (TyAll t1) = nub ((freeVariablesType (STypeVar c) t1))
freeVariablesType c (TyInt) = nub ([])
freeVariablesType c (TyTop) = nub ([])
freeVariablesType c (TyProd t1 t2) =
nub ((freeVariablesType c t1) ++ (freeVariablesType c t2))
freeVariablesTerm :: HNat -> Term -> [HNat]
freeVariablesTerm c (TmVar hnat)
| hnat >= c = [minus hnat c]
| otherwise = []
freeVariablesTerm c (TmAbs x t) =
nub ((freeVariablesTerm (STermVar c) x) ++ (freeVariablesType c t))
freeVariablesTerm c (TmApp t1 t2) =
nub ((freeVariablesTerm c t1) ++ (freeVariablesTerm c t2))
freeVariablesTerm c (TmTApp t1 t) =
nub ((freeVariablesTerm c t1) ++ (freeVariablesType c t))
freeVariablesTerm c (TmTAbs t1) = nub ((freeVariablesTerm (STypeVar c) t1))
freeVariablesTerm c (TmTop) = nub ([])
freeVariablesTerm c (TmTuple e1 e2) =
nub ((freeVariablesTerm c e1) ++ (freeVariablesTerm c e2))
freeVariablesTerm c (TmInt _) = nub ([])
freeVariablesTerm c (TmCast co e) =
nub ((freeVariablesCoercion c co) ++ (freeVariablesTerm c e))
module FCoBase where
import Data.List
data Variable = Z | STermVar Variable | STypeVar Variable deriving(Show, Eq)
data Term = TmVar Variable | TmAbs Term Type | TmApp Term Term | TmTApp Term Type | TmTAbs Term | TmTop | TmTuple Term Term | TmInt Int | TmCast Coercion Term deriving(Show, Eq)
data Type = TyVar Variable | TyArr Type Type | TyAll Type | TyInt | TyTop | TyProd Type Type deriving(Show, Eq)
data Coercion = CoId | CoTrans Coercion Coercion | CoTop Type | CoBot Type | CoArrow Coercion Coercion | CoTuple Coercion Coercion | CoProj1 Type | CoProj2 Type | CoAll Coercion | CoDistArrow | CoTopArrow | CoTopAll | CoDistAll deriving(Show, Eq)
plus (Z) h = h
plus h (Z) = h
plus x1 (STermVar x2) = (STermVar (plus x1 x2))
plus x1 (STypeVar x2) = (STypeVar (plus x1 x2))
minus (Z) (Z) = (Z)
minus (Z) _ = (error "You cannot substract zero with a positive number")
minus result (Z) = result
minus (STermVar h1) (STermVar h2) = (minus h1 h2)
minus (STermVar h1) (STypeVar h2) = (error "differing namespace found in minus")
minus (STypeVar h1) (STermVar h2) = (error "differing namespace found in minus")
minus (STypeVar h1) (STypeVar h2) = (minus h1 h2)
generateHnatTermVar 0 c = c
generateHnatTermVar n c = (STermVar (generateHnatTermVar (n - 1) c))
generateHnatTypeVar 0 c = c
generateHnatTypeVar n c = (STypeVar (generateHnatTypeVar (n - 1) c))
termshiftHelpplus d c (TmVar var) = if (var >= c) then (TmVar (plus var d)) else (TmVar var)
typeshiftHelpplus d c (TyVar var) = if (var >= c) then (TyVar (plus var d)) else (TyVar var)
termshiftplus d t = (termmap (termshiftHelpplus d) (typeshiftHelpplus d) (Z) t)
typeshiftplus d t = (typemap (typeshiftHelpplus d) (Z) t)
coercionshiftplus d t = (coercionmap (typeshiftHelpplus d) (Z) t)
termshiftHelpminus d c (TmVar var) = if (var >= c) then (TmVar (minus var d)) else (TmVar var)
typeshiftHelpminus d c (TyVar var) = if (var >= c) then (TyVar (minus var d)) else (TyVar var)
termshiftminus d t = (termmap (termshiftHelpminus d) (typeshiftHelpminus d) (Z) t)