Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Gilles Coremans
ASTTool
Commits
6bc0c710
Commit
6bc0c710
authored
Apr 14, 2020
by
marton bognar
Browse files
Use updated FCo and Fi+ specifications for their implementation
parent
771b759b
Changes
8
Hide whitespace changes
Inline
Side-by-side
FCO/Elaborate.hs
View file @
6bc0c710
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
(
TmApp
Co
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
(
TmTuple
Co
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
(
TmTApp
Co
term
(
convertType
ty
))
elaborate
(
TmAll
ty
t
)
ctx
=
do
term
<-
elaborate
t
(
ETypeVar
ty
ctx
)
return
(
TmTAbs
Co
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
=
TyInt
Co
convertType
(
TyAnd
ty1
ty2
)
=
TyProd
Co
(
convertType
ty1
)
(
convertType
ty2
)
convertType
TyBot
=
TyAll
Co
(
TyVar
Co
Z
)
convertType
TyTop
=
TyTop
Co
convertType
(
TyRecord
ty
_
)
=
convertType
ty
convertType
(
TyVar
hnat
)
=
TyVar
Co
hnat
convertType
(
TyArr
ty1
ty2
)
=
TyArr
Co
(
convertType
ty1
)
(
convertType
ty2
)
convertType
(
TyAll
ty
tyB
)
=
TyAll
Co
(
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
_
=
False
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
FCO/FCO.hs
deleted
100644 → 0
View file @
771b759b
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
))
FCO/FCoBase.hs
0 → 100644
View file @
6bc0c710
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
)