Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
08cc34f2
Commit
08cc34f2
authored
Jul 06, 2020
by
Fredrik Wieczerkowski
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Revert everything since 'higher-rank-polymorphism' (
!14
)
parent
83978093
Changes
107
Expand all
Hide whitespace changes
Inline
Side-by-side
Showing
107 changed files
with
8132 additions
and
11096 deletions
+8132
-11096
CHANGELOG.md
CHANGELOG.md
+0
-12
data/currysource.css
data/currysource.css
+27
-81
src/Base/AnnotExpr.hs
src/Base/AnnotExpr.hs
+13
-13
src/Base/CurryKinds.hs
src/Base/CurryKinds.hs
+4
-4
src/Base/CurryTypes.hs
src/Base/CurryTypes.hs
+41
-42
src/Base/Expr.hs
src/Base/Expr.hs
+29
-25
src/Base/PrettyKinds.hs
src/Base/PrettyKinds.hs
+1
-1
src/Base/PrettyTypes.hs
src/Base/PrettyTypes.hs
+20
-8
src/Base/Subst.hs
src/Base/Subst.hs
+1
-4
src/Base/TopEnv.hs
src/Base/TopEnv.hs
+4
-4
src/Base/TypeExpansion.hs
src/Base/TypeExpansion.hs
+41
-51
src/Base/TypeSubst.hs
src/Base/TypeSubst.hs
+85
-79
src/Base/Types.hs
src/Base/Types.hs
+335
-288
src/Base/Typing.hs
src/Base/Typing.hs
+17
-21
src/Base/Utils.hs
src/Base/Utils.hs
+47
-53
src/Checks.hs
src/Checks.hs
+10
-21
src/Checks/DeriveCheck.hs
src/Checks/DeriveCheck.hs
+17
-14
src/Checks/ExportCheck.hs
src/Checks/ExportCheck.hs
+19
-25
src/Checks/ExtensionCheck.hs
src/Checks/ExtensionCheck.hs
+1
-1
src/Checks/ImpredCheck.hs
src/Checks/ImpredCheck.hs
+0
-165
src/Checks/InstanceCheck.hs
src/Checks/InstanceCheck.hs
+51
-107
src/Checks/InterfaceCheck.hs
src/Checks/InterfaceCheck.hs
+25
-30
src/Checks/InterfaceSyntaxCheck.hs
src/Checks/InterfaceSyntaxCheck.hs
+32
-26
src/Checks/KindCheck.hs
src/Checks/KindCheck.hs
+88
-87
src/Checks/PrecCheck.hs
src/Checks/PrecCheck.hs
+18
-21
src/Checks/SyntaxCheck.hs
src/Checks/SyntaxCheck.hs
+130
-153
src/Checks/TypeCheck.hs
src/Checks/TypeCheck.hs
+1041
-1305
src/Checks/TypeSyntaxCheck.hs
src/Checks/TypeSyntaxCheck.hs
+325
-378
src/Checks/WarnCheck.hs
src/Checks/WarnCheck.hs
+120
-334
src/CompilerOpts.hs
src/CompilerOpts.hs
+46
-84
src/CurryBuilder.hs
src/CurryBuilder.hs
+9
-9
src/CurryDeps.hs
src/CurryDeps.hs
+3
-3
src/Env/Instance.hs
src/Env/Instance.hs
+2
-5
src/Env/TypeConstructor.hs
src/Env/TypeConstructor.hs
+2
-2
src/Env/Value.hs
src/Env/Value.hs
+40
-38
src/Exports.hs
src/Exports.hs
+39
-31
src/Generators.hs
src/Generators.hs
+3
-3
src/Generators/GenAbstractCurry.hs
src/Generators/GenAbstractCurry.hs
+60
-61
src/Generators/GenTypeAnnotatedFlatCurry.hs
src/Generators/GenTypeAnnotatedFlatCurry.hs
+32
-66
src/Generators/GenTypedFlatCurry.hs
src/Generators/GenTypedFlatCurry.hs
+30
-62
src/Html/CurryHtml.hs
src/Html/CurryHtml.hs
+24
-24
src/Html/SyntaxColoring.hs
src/Html/SyntaxColoring.hs
+37
-32
src/IL/Pretty.hs
src/IL/Pretty.hs
+2
-8
src/IL/ShowModule.hs
src/IL/ShowModule.hs
+0
-13
src/IL/Type.hs
src/IL/Type.hs
+3
-14
src/IL/Typing.hs
src/IL/Typing.hs
+3
-17
src/Imports.hs
src/Imports.hs
+43
-45
src/Interfaces.hs
src/Interfaces.hs
+1
-1
src/Modules.hs
src/Modules.hs
+44
-48
src/Transformations.hs
src/Transformations.hs
+12
-14
src/Transformations/CaseCompletion.hs
src/Transformations/CaseCompletion.hs
+24
-49
src/Transformations/CurryToIL.hs
src/Transformations/CurryToIL.hs
+68
-213
src/Transformations/Derive.hs
src/Transformations/Derive.hs
+163
-233
src/Transformations/Desugar.hs
src/Transformations/Desugar.hs
+180
-208
src/Transformations/Dictionary.hs
src/Transformations/Dictionary.hs
+242
-248
src/Transformations/Lift.hs
src/Transformations/Lift.hs
+21
-22
src/Transformations/Newtypes.hs
src/Transformations/Newtypes.hs
+7
-9
src/Transformations/Qual.hs
src/Transformations/Qual.hs
+36
-34
src/Transformations/Simplify.hs
src/Transformations/Simplify.hs
+26
-26
test/TestFrontend.hs
test/TestFrontend.hs
+96
-241
test/fail/AmbiguousTypeVariable.curry
test/fail/AmbiguousTypeVariable.curry
+0
-16
test/fail/ClassHiddenExport.curry
test/fail/ClassHiddenExport.curry
+0
-8
test/fail/ClassHiddenFail.curry
test/fail/ClassHiddenFail.curry
+0
-7
test/fail/DataFail.curry
test/fail/DataFail.curry
+0
-12
test/fail/EscapingTypeVariable.curry
test/fail/EscapingTypeVariable.curry
+0
-41
test/fail/ImpredDollar.curry
test/fail/ImpredDollar.curry
+0
-14
test/fail/ImpredPoly.curry
test/fail/ImpredPoly.curry
+0
-22
test/fail/ImpredPolyUnify.curry
test/fail/ImpredPolyUnify.curry
+0
-25
test/fail/IncompatibleTypes.curry
test/fail/IncompatibleTypes.curry
+0
-6
test/fail/MissingLabelInUpdate.curry
test/fail/MissingLabelInUpdate.curry
+0
-6
test/fail/MissingLabelInUpdateExport.curry
test/fail/MissingLabelInUpdateExport.curry
+0
-4
test/fail/Prelude.curry
test/fail/Prelude.curry
+1427
-1680
test/fail/RankNTypes.curry
test/fail/RankNTypes.curry
+0
-10
test/fail/RankNTypesFuncPats.curry
test/fail/RankNTypesFuncPats.curry
+0
-11
test/fail/Subsumption.curry
test/fail/Subsumption.curry
+0
-37
test/fail/TypeSigTooGeneral.curry
test/fail/TypeSigTooGeneral.curry
+0
-12
test/fail/UnboundTypeVariable.curry
test/fail/UnboundTypeVariable.curry
+0
-8
test/pass/ACVisibility.curry
test/pass/ACVisibility.curry
+1
-0
test/pass/ApLhs.curry
test/pass/ApLhs.curry
+0
-4
test/pass/ChurchEncoding.curry
test/pass/ChurchEncoding.curry
+0
-83
test/pass/ClassHiddenExport.curry
test/pass/ClassHiddenExport.curry
+0
-8
test/pass/ClassHiddenPass.curry
test/pass/ClassHiddenPass.curry
+0
-6
test/pass/ClassMethods.curry
test/pass/ClassMethods.curry
+0
-11
test/pass/DataPass.curry
test/pass/DataPass.curry
+0
-14
test/pass/EmptyWhere.curry
test/pass/EmptyWhere.curry
+0
-6
test/pass/ExplicitForAll.curry
test/pass/ExplicitForAll.curry
+0
-10
test/pass/FP_Lifting.curry
test/pass/FP_Lifting.curry
+6
-5
test/pass/FP_NonLinearity.curry
test/pass/FP_NonLinearity.curry
+3
-3
test/pass/HaskellRecords.curry
test/pass/HaskellRecords.curry
+1
-1
test/pass/ImportRestricted.curry
test/pass/ImportRestricted.curry
+0
-3
test/pass/ImportRestricted2.curry
test/pass/ImportRestricted2.curry
+0
-10
test/pass/ImportRestrictedExport.curry
test/pass/ImportRestrictedExport.curry
+0
-3
test/pass/ImpredDollar.curry
test/pass/ImpredDollar.curry
+0
-13
test/pass/Monad.curry
test/pass/Monad.curry
+0
-44
test/pass/PatDecl.curry
test/pass/PatDecl.curry
+0
-9
test/pass/Prelude.curry
test/pass/Prelude.curry
+1427
-1680
test/pass/RankNTypes.curry
test/pass/RankNTypes.curry
+0
-172
test/pass/RankNTypesImport.curry
test/pass/RankNTypesImport.curry
+0
-4
test/pass/ScottEncoding.curry
test/pass/ScottEncoding.curry
+0
-58
test/pass/Subsumption.curry
test/pass/Subsumption.curry
+0
-55
test/pass/TermInv.curry
test/pass/TermInv.curry
+0
-30
test/pass/WhereAfterDo.curry
test/pass/WhereAfterDo.curry
+0
-10
test/warning/NoRedundant.curry
test/warning/NoRedundant.curry
+0
-11
test/warning/Prelude.curry
test/warning/Prelude.curry
+1427
-1680
test/warning/QualRedundant.curry
test/warning/QualRedundant.curry
+0
-8
test/warning/Redundant.curry
test/warning/Redundant.curry
+0
-6
test/warning/TypeVariableShadowing.curry
test/warning/TypeVariableShadowing.curry
+0
-14
No files found.
CHANGELOG.md
View file @
08cc34f2
Change log for curry-frontend
=============================
Version 2.0.0
=============
*
Implemented the "MonadFail-Proposal" for curry
(see
<https://wiki.haskell.org/MonadFail_Proposal>
)
*
Data class (see
<https://arxiv.org/abs/1908.10607>
)
*
RankNTypes
*
Fixed bug with partially imported Typeclasses
*
Fixed bug with parsing of empty blocks
*
Fixed bug with re-export of record labels
Version 1.0.4
=============
*
Fixed bug in type checking of instances
*
Fixed bugs in deriving of
`Bounded`
instances.
Version 1.0.3
=============
...
...
data/currysource.css
View file @
08cc34f2
:root
{
--link-bg-color
:
lightyellow
;
--line-number-color
:
grey
;
--pragma-color
:
green
;
--comment-color
:
green
;
--keyword-color
:
blue
;
--symbol-color
:
red
;
--type-color
:
orange
;
--cons-color
:
magenta
;
--label-color
:
darkgreen
;
--func-color
:
purple
;
--ident-color
:
black
;
--module-color
:
brown
;
--number-color
:
teal
;
--string-color
:
maroon
;
--char-color
:
maroon
;
color-scheme
:
light
dark
;
}
/* Use always white background */
body
{
background
:
white
;
color
:
black
;
font-family
:
monospace
;
text-size-adjust
:
none
;
-moz-text-size-adjust
:
none
;
-ms-text-size-adjust
:
none
;
-webkit-text-size-adjust
:
none
;
}
table
{
border-collapse
:
collapse
;
}
/* Hyperlinks */
a
:link
,
a
:visited
,
a
:active
{
background
:
var
(
--link-bg-color
);
/* Show hyperlinks without text decoration, but in light yellow */
a
:visited
,
a
:link
,
a
:active
{
text-decoration
:
none
;
background
:
lightyellow
;
}
/* Line numbers */
.line
-
numbers
{
border-right
:
1px
solid
var
(
--line-number-color
)
;
color
:
var
(
--line-number-color
)
;
min-width
:
5ch
;
padding-right
:
1
em
;
text-align
:
right
;
.linenumbers
{
width
:
40px
;
text-align
:
right
;
color
:
grey
;
padding-right
:
1
0px
;
border-right
:
1px
solid
grey
;
}
/* Source code */
.source
-
code
{
padding-left
:
1
em
;
.sourcecode
{
padding-left
:
1
0px
;
}
/* Code highlighting */
.pragma
{
color
:
var
(
--pragma-color
)
}
.comment
{
color
:
var
(
--comment-color
)
}
.keyword
{
color
:
var
(
--keyword-color
)
}
.symbol
{
color
:
var
(
--symbol-color
)
}
.type
{
color
:
var
(
--type-color
)
}
.cons
{
color
:
var
(
--cons-color
)
}
.label
{
color
:
var
(
--label-color
)
}
.func
{
color
:
var
(
--func-color
)
}
.ident
{
color
:
var
(
--ident-color
)
}
.module
{
color
:
var
(
--module-color
)
}
.number
{
color
:
var
(
--number-color
)
}
.string
{
color
:
var
(
--string-color
)
}
.char
{
color
:
var
(
--char-color
)
}
@supports
not
(
color-scheme
:
light
dark
)
{
@media
(
prefers-color-scheme
:
dark
)
{
html
{
background
:
hsl
(
0
,
0%
,
12%
);
color
:
white
;
}
}
}
@media
(
prefers-color-scheme
:
dark
)
{
:root
{
--link-bg-color
:
hsl
(
0
,
0%
,
17%
);
--pragma-color
:
hsl
(
0
,
0%
,
60%
);
--comment-color
:
hsl
(
0
,
0%
,
60%
);
--keyword-color
:
hsl
(
300
,
66%
,
70%
);
--symbol-color
:
hsl
(
0
,
66%
,
70%
);
--type-color
:
hsl
(
60
,
66%
,
70%
);
--cons-color
:
hsl
(
330
,
66%
,
70%
);
--label-color
:
hsl
(
240
,
66%
,
70%
);
--func-color
:
hsl
(
200
,
66%
,
70%
);
--ident-color
:
hsl
(
0
,
0%
,
85%
);
--module-color
:
hsl
(
20
,
66%
,
70%
);
--number-color
:
hsl
(
180
,
66%
,
70%
);
--string-color
:
hsl
(
120
,
66%
,
70%
);
--char-color
:
hsl
(
120
,
66%
,
70%
);
}
}
.pragma
{
color
:
green
}
.comment
{
color
:
green
}
.keyword
{
color
:
blue
}
.symbol
{
color
:
red
}
.type
{
color
:
orange
}
.cons
{
color
:
magenta
}
.label
{
color
:
darkgreen
}
.func
{
color
:
purple
}
.ident
{
color
:
black
}
.module
{
color
:
brown
}
.number
{
color
:
teal
}
.string
{
color
:
maroon
}
.char
{
color
:
maroon
}
src/Base/AnnotExpr.hs
View file @
08cc34f2
...
...
@@ -33,11 +33,11 @@ class QualAnnotExpr e where
-- variables cannot be computed independently for each declaration.
instance
QualAnnotExpr
Decl
where
qafv
m
(
FunctionDecl
_
_
_
eqs
)
=
concatMap
(
qafv
m
)
eqs
qafv
m
(
PatternDecl
_
_
rhs
)
=
qafv
m
rhs
qafv
m
(
ClassDecl
_
_
_
_
_
ds
)
=
concatMap
(
qafv
m
)
ds
qafv
m
(
InstanceDecl
_
_
_
_
_
ds
)
=
concatMap
(
qafv
m
)
ds
qafv
_
_
=
[]
qafv
m
(
FunctionDecl
_
_
_
eqs
)
=
concatMap
(
qafv
m
)
eqs
qafv
m
(
PatternDecl
_
_
rhs
)
=
qafv
m
rhs
qafv
m
(
ClassDecl
_
_
_
_
ds
)
=
concatMap
(
qafv
m
)
ds
qafv
m
(
InstanceDecl
_
_
_
_
ds
)
=
concatMap
(
qafv
m
)
ds
qafv
_
_
=
[]
instance
QualAnnotExpr
Equation
where
qafv
m
(
Equation
_
lhs
rhs
)
=
filterBv
lhs
$
qafv
m
lhs
++
qafv
m
rhs
...
...
@@ -46,8 +46,8 @@ instance QualAnnotExpr Lhs where
qafv
m
=
concatMap
(
qafv
m
)
.
snd
.
flatLhs
instance
QualAnnotExpr
Rhs
where
qafv
m
(
SimpleRhs
_
_
e
ds
)
=
filterBv
ds
$
qafv
m
e
++
concatMap
(
qafv
m
)
ds
qafv
m
(
GuardedRhs
_
_
es
ds
)
=
qafv
m
(
SimpleRhs
_
e
ds
)
=
filterBv
ds
$
qafv
m
e
++
concatMap
(
qafv
m
)
ds
qafv
m
(
GuardedRhs
_
es
ds
)
=
filterBv
ds
$
concatMap
(
qafv
m
)
es
++
concatMap
(
qafv
m
)
ds
instance
QualAnnotExpr
CondExpr
where
...
...
@@ -75,11 +75,11 @@ instance QualAnnotExpr Expression where
qafv
m
(
LeftSection
_
e
op
)
=
qafv
m
op
++
qafv
m
e
qafv
m
(
RightSection
_
op
e
)
=
qafv
m
op
++
qafv
m
e
qafv
m
(
Lambda
_
ts
e
)
=
filterBv
ts
$
qafv
m
e
qafv
m
(
Let
_
_
ds
e
)
=
qafv
m
(
Let
_
ds
e
)
=
filterBv
ds
$
concatMap
(
qafv
m
)
ds
++
qafv
m
e
qafv
m
(
Do
_
_
sts
e
)
=
foldr
(
qafvStmt
m
)
(
qafv
m
e
)
sts
qafv
m
(
Do
_
sts
e
)
=
foldr
(
qafvStmt
m
)
(
qafv
m
e
)
sts
qafv
m
(
IfThenElse
_
e1
e2
e3
)
=
qafv
m
e1
++
qafv
m
e2
++
qafv
m
e3
qafv
m
(
Case
_
_
_
e
alts
)
=
qafv
m
e
++
concatMap
(
qafv
m
)
alts
qafv
m
(
Case
_
_
e
alts
)
=
qafv
m
e
++
concatMap
(
qafv
m
)
alts
qafvField
::
QualAnnotExpr
e
=>
ModuleIdent
->
Field
(
e
Type
)
->
[(
Type
,
Ident
)]
qafvField
m
(
Field
_
_
t
)
=
qafv
m
t
...
...
@@ -88,9 +88,9 @@ qafvStmt :: ModuleIdent -> Statement Type -> [(Type, Ident)] -> [(Type, Ident)]
qafvStmt
m
st
fvs
=
qafv
m
st
++
filterBv
st
fvs
instance
QualAnnotExpr
Statement
where
qafv
m
(
StmtExpr
_
e
)
=
qafv
m
e
qafv
m
(
StmtDecl
_
_
ds
)
=
filterBv
ds
$
concatMap
(
qafv
m
)
ds
qafv
m
(
StmtBind
_
_
e
)
=
qafv
m
e
qafv
m
(
StmtExpr
_
e
)
=
qafv
m
e
qafv
m
(
StmtDecl
_
ds
)
=
filterBv
ds
$
concatMap
(
qafv
m
)
ds
qafv
m
(
StmtBind
_
_
e
)
=
qafv
m
e
instance
QualAnnotExpr
Alt
where
qafv
m
(
Alt
_
t
rhs
)
=
filterBv
t
$
qafv
m
rhs
...
...
src/Base/CurryKinds.hs
View file @
08cc34f2
...
...
@@ -19,9 +19,9 @@ module Base.CurryKinds
(
toKind
,
toKind'
,
fromKind
,
fromKind'
,
ppKind
)
where
import
Curry.Base.Pretty
(
Doc
)
import
Curry.Syntax.Pretty
(
p
PrintPrec
)
import
Curry.Syntax.Type
(
KindExpr
(
..
))
import
Curry.Base.Pretty
(
Doc
)
import
Curry.Syntax.Pretty
(
p
pKindExpr
)
import
Curry.Syntax.Type
(
KindExpr
(
..
))
import
Base.Kinds
...
...
@@ -42,4 +42,4 @@ fromKind' k n | k == simpleKind n = Nothing
|
otherwise
=
Just
(
fromKind
k
)
ppKind
::
Kind
->
Doc
ppKind
=
p
PrintPrec
0
.
fromKind
ppKind
=
p
pKindExpr
0
.
fromKind
src/Base/CurryTypes.hs
View file @
08cc34f2
...
...
@@ -30,7 +30,7 @@ module Base.CurryTypes
,
fromType
,
fromQualType
,
fromPred
,
fromQualPred
,
fromPredSet
,
fromQualPredSet
,
fromPredType
,
fromQualPredType
,
ppType
,
ppPred
,
ppPred
Set
,
ppPredTyp
e
,
ppType
,
ppPred
,
ppPred
Type
,
ppTypeSchem
e
)
where
import
Data.List
(
nub
)
...
...
@@ -38,10 +38,10 @@ import qualified Data.Map as Map (Map, fromList, lookup)
import
qualified
Data.Set
as
Set
import
Curry.Base.Ident
import
Curry.Base.Pretty
(
Doc
,
list
,
parens
)
import
Curry.Base.Pretty
(
Doc
)
import
Curry.Base.SpanInfo
import
qualified
Curry.Syntax
as
CS
import
Curry.Syntax.Pretty
(
p
Print
,
pPrintPrec
)
import
Curry.Syntax.Pretty
(
p
pConstraint
,
ppTypeExpr
,
ppQualTypeExpr
)
import
Base.Expr
import
Base.Messages
(
internalError
)
...
...
@@ -76,11 +76,6 @@ toType' tvs (CS.ArrowType _ ty1 ty2) tys
|
null
tys
=
TypeArrow
(
toType'
tvs
ty1
[]
)
(
toType'
tvs
ty2
[]
)
|
otherwise
=
internalError
"Base.CurryTypes.toType': arrow type application"
toType'
tvs
(
CS
.
ParenType
_
ty
)
tys
=
toType'
tvs
ty
tys
toType'
tvs
(
CS
.
ContextType
_
cx
ty
)
tys
|
null
cx
=
toType'
tvs
ty
tys
|
otherwise
=
applyType
(
TypeContext
(
toPredSet'
tvs
cx
)
(
toType'
tvs
ty
[]
))
tys
toType'
tvs
(
CS
.
ForallType
_
tvs'
ty
)
tys
|
null
tvs'
=
toType'
tvs
ty
tys
|
otherwise
=
applyType
(
TypeForall
(
map
(
toVar
tvs
)
tvs'
)
...
...
@@ -116,41 +111,47 @@ toPredSet' tvs = Set.fromList . map (toPred' tvs)
toQualPredSet
::
ModuleIdent
->
[
Ident
]
->
CS
.
Context
->
PredSet
toQualPredSet
m
tvs
=
qualifyPredSet
m
.
toPredSet
tvs
toPredType
::
[
Ident
]
->
CS
.
TypeExpr
->
Type
toPredType
tvs
ty
=
toPredType'
(
enumTypeVars
tvs
ty
)
ty
toPredType
::
[
Ident
]
->
CS
.
Qual
TypeExpr
->
Pred
Type
toPredType
tvs
q
ty
=
toPredType'
(
enumTypeVars
tvs
q
ty
)
q
ty
toPredType'
::
Map
.
Map
Ident
Int
->
CS
.
TypeExpr
->
Type
toPredType'
tvs
(
CS
.
ContextType
_
cx
ty
)
=
TypeContext
(
toPredSet'
tvs
cx
)
(
toType'
tvs
ty
[]
)
toPredType'
tvs
ty
=
TypeContext
(
toPredSet'
tvs
[]
)
(
toType'
tvs
ty
[]
)
toPredType'
::
Map
.
Map
Ident
Int
->
CS
.
QualTypeExpr
->
PredType
toPredType'
tvs
(
CS
.
QualTypeExpr
_
cx
ty
)
=
PredType
(
toPredSet'
tvs
cx
)
(
toType'
tvs
ty
[]
)
toQualPredType
::
ModuleIdent
->
[
Ident
]
->
CS
.
TypeExpr
->
Type
toQualPredType
m
tvs
=
qualifyType
m
.
toPredType
tvs
toQualPredType
::
ModuleIdent
->
[
Ident
]
->
CS
.
Qual
TypeExpr
->
Pred
Type
toQualPredType
m
tvs
=
qualify
Pred
Type
m
.
toPredType
tvs
-- The function 'toConstrType' returns the type of a data or newtype
-- constructor. Hereby, it restricts the context to those type variables
-- which are free in the argument types.
toConstrType
::
QualIdent
->
[
Ident
]
->
[
CS
.
TypeExpr
]
->
Type
toConstrType
tc
tvs
tys
=
toPredType
tvs
$
CS
.
ContextType
NoSpanInfo
[]
ty'
where
ty'
=
foldr
(
CS
.
ArrowType
NoSpanInfo
)
ty0
tys
toConstrType
::
QualIdent
->
[
Ident
]
->
CS
.
Context
->
[
CS
.
TypeExpr
]
->
PredType
toConstrType
tc
tvs
cx
tys
=
toPredType
tvs
$
CS
.
QualTypeExpr
NoSpanInfo
cx'
ty'
where
tvs'
=
nub
(
fv
tys
)
cx'
=
restrictContext
tvs'
cx
ty'
=
foldr
(
CS
.
ArrowType
NoSpanInfo
)
ty0
tys
ty0
=
foldl
(
CS
.
ApplyType
NoSpanInfo
)
(
CS
.
ConstructorType
NoSpanInfo
tc
)
(
map
(
CS
.
VariableType
NoSpanInfo
)
tvs
)
restrictContext
::
[
Ident
]
->
CS
.
Context
->
CS
.
Context
restrictContext
tvs
cx
=
[
CS
.
Constraint
spi
cls
ty
|
CS
.
Constraint
spi
cls
ty
<-
cx
,
classVar
ty
`
elem
`
tvs
]
where
classVar
(
CS
.
VariableType
_
tv
)
=
tv
classVar
(
CS
.
ApplyType
_
ty
_
)
=
classVar
ty
classVar
_
=
internalError
"Base.CurryTypes.restrictContext.classVar"
-- The function 'toMethodType' returns the type of a type class method.
-- It adds the implicit type class constraint to the method's type signature
-- and ensures that the class' type variable is always assigned index 0.
toMethodType
::
QualIdent
->
Ident
->
CS
.
TypeExpr
->
Type
toMethodType
qcls
clsvar
(
CS
.
ContextType
spi
cx
ty
)
=
toPredType
[
clsvar
]
(
CS
.
ContextType
spi
cx'
ty
)
toMethodType
::
QualIdent
->
Ident
->
CS
.
Qual
TypeExpr
->
Pred
Type
toMethodType
qcls
clsvar
(
CS
.
QualTypeExpr
spi
cx
ty
)
=
toPredType
[
clsvar
]
(
CS
.
QualTypeExpr
spi
cx'
ty
)
where
cx'
=
CS
.
Constraint
NoSpanInfo
qcls
(
CS
.
VariableType
NoSpanInfo
clsvar
)
:
cx
toMethodType
qcls
clsvar
ty
=
toPredType
[
clsvar
]
(
CS
.
ContextType
NoSpanInfo
cx'
ty
)
where
cx'
=
[
CS
.
Constraint
NoSpanInfo
qcls
(
CS
.
VariableType
NoSpanInfo
clsvar
)]
fromType
::
[
Ident
]
->
Type
->
CS
.
TypeExpr
fromType
tvs
ty
=
fromType'
tvs
ty
[]
...
...
@@ -172,10 +173,9 @@ fromType' tvs (TypeArrow ty1 ty2) tys =
foldl
(
CS
.
ApplyType
NoSpanInfo
)
(
CS
.
ArrowType
NoSpanInfo
(
fromType
tvs
ty1
)
(
fromType
tvs
ty2
))
tys
fromType'
tvs
(
TypeConstrained
tys
_
)
tys'
=
fromType'
tvs
(
head
tys
)
tys'
fromType'
tvs
(
TypeContext
ps
ty
)
tys
=
foldl
(
CS
.
ApplyType
NoSpanInfo
)
(
CS
.
ContextType
NoSpanInfo
(
fromPredSet
tvs
ps
)
(
fromType
tvs
ty
))
tys
fromType'
_
(
TypeSkolem
k
)
tys
=
foldl
(
CS
.
ApplyType
NoSpanInfo
)
(
CS
.
VariableType
NoSpanInfo
$
mkIdent
$
"_?"
++
show
k
)
tys
fromType'
tvs
(
TypeForall
tvs'
ty
)
tys
|
null
tvs'
=
fromType'
tvs
ty
tys
|
otherwise
=
foldl
(
CS
.
ApplyType
NoSpanInfo
)
...
...
@@ -204,24 +204,23 @@ fromPredSet tvs = map (fromPred tvs) . Set.toAscList
fromQualPredSet
::
ModuleIdent
->
[
Ident
]
->
PredSet
->
CS
.
Context
fromQualPredSet
m
tvs
=
fromPredSet
tvs
.
unqualifyPredSet
m
fromPredType
::
[
Ident
]
->
Type
->
CS
.
TypeExpr
fromPredType
tvs
(
TypeContext
ps
ty
)
=
CS
.
ContextType
NoSpanInfo
(
fromPredSet
tvs
ps
)
(
fromType
tvs
ty
)
fromPredType
tvs
ty
=
fromType
tvs
ty
fromPredType
::
[
Ident
]
->
PredType
->
CS
.
QualTypeExpr
fromPredType
tvs
(
PredType
ps
ty
)
=
CS
.
QualTypeExpr
NoSpanInfo
(
fromPredSet
tvs
ps
)
(
fromType
tvs
ty
)
fromQualPredType
::
ModuleIdent
->
[
Ident
]
->
Type
->
CS
.
TypeExpr
fromQualPredType
m
tvs
=
fromPredType
tvs
.
unqualifyType
m
fromQualPredType
::
ModuleIdent
->
[
Ident
]
->
Pred
Type
->
CS
.
Qual
TypeExpr
fromQualPredType
m
tvs
=
fromPredType
tvs
.
unqualify
Pred
Type
m
-- The following functions implement pretty-printing for types.
ppType
::
ModuleIdent
->
Type
->
Doc
ppType
m
=
p
PrintPrec
0
.
fromQualType
m
identSupply
ppType
m
=
p
pTypeExpr
0
.
fromQualType
m
identSupply
ppPred
::
ModuleIdent
->
Pred
->
Doc
ppPred
m
=
p
Pr
int
.
fromQualPred
m
identSupply
ppPred
m
=
p
pConstra
int
.
fromQualPred
m
identSupply
ppPred
Set
::
ModuleIdent
->
Pred
Set
->
Doc
ppPred
Set
m
=
p
arens
.
list
.
map
(
ppPred
m
)
.
Set
.
toList
ppPred
Type
::
ModuleIdent
->
Pred
Type
->
Doc
ppPred
Type
m
=
p
pQualTypeExpr
.
fromQualPredType
m
identSupply
pp
PredTyp
e
::
ModuleIdent
->
Type
->
Doc
pp
PredType
m
=
pPrintPrec
0
.
fromQual
PredType
m
identSuppl
y
pp
TypeSchem
e
::
ModuleIdent
->
Type
Scheme
->
Doc
pp
TypeScheme
m
(
ForAll
_
pty
)
=
pp
PredType
m
pt
y
src/Base/Expr.hs
View file @
08cc34f2
...
...
@@ -58,20 +58,20 @@ instance QuantExpr e => QuantExpr [e] where
-- variables cannot be computed independently for each declaration.
instance
QualExpr
(
Decl
a
)
where
qfv
m
(
FunctionDecl
_
_
_
eqs
)
=
qfv
m
eqs
qfv
m
(
PatternDecl
_
_
rhs
)
=
qfv
m
rhs
qfv
m
(
ClassDecl
_
_
_
_
_
ds
)
=
qfv
m
ds
qfv
m
(
InstanceDecl
_
_
_
_
_
ds
)
=
qfv
m
ds
qfv
_
_
=
[]
qfv
m
(
FunctionDecl
_
_
_
eqs
)
=
qfv
m
eqs
qfv
m
(
PatternDecl
_
_
rhs
)
=
qfv
m
rhs
qfv
m
(
ClassDecl
_
_
_
_
ds
)
=
qfv
m
ds
qfv
m
(
InstanceDecl
_
_
_
_
ds
)
=
qfv
m
ds
qfv
_
_
=
[]
instance
QuantExpr
(
Decl
a
)
where
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
FunctionDecl
_
_
f
_
)
=
[
f
]
bv
(
ExternalDecl
_
vs
)
=
bv
vs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
FreeDecl
_
vs
)
=
bv
vs
bv
(
ClassDecl
_
_
_
_
_
ds
)
=
concatMap
methods
ds
bv
_
=
[]
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
FunctionDecl
_
_
f
_
)
=
[
f
]
bv
(
ExternalDecl
_
vs
)
=
bv
vs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
FreeDecl
_
vs
)
=
bv
vs
bv
(
ClassDecl
_
_
_
_
ds
)
=
concatMap
methods
ds
bv
_
=
[]
instance
QualExpr
(
Equation
a
)
where
qfv
m
(
Equation
_
lhs
rhs
)
=
filterBv
lhs
$
qfv
m
lhs
++
qfv
m
rhs
...
...
@@ -83,8 +83,8 @@ instance QualExpr (Lhs a) where
qfv
m
lhs
=
qfv
m
$
snd
$
flatLhs
lhs
instance
QualExpr
(
Rhs
a
)
where
qfv
m
(
SimpleRhs
_
_
e
ds
)
=
filterBv
ds
$
qfv
m
e
++
qfv
m
ds
qfv
m
(
GuardedRhs
_
_
es
ds
)
=
filterBv
ds
$
qfv
m
es
++
qfv
m
ds
qfv
m
(
SimpleRhs
_
e
ds
)
=
filterBv
ds
$
qfv
m
e
++
qfv
m
ds
qfv
m
(
GuardedRhs
_
es
ds
)
=
filterBv
ds
$
qfv
m
es
++
qfv
m
ds
instance
QualExpr
(
CondExpr
a
)
where
qfv
m
(
CondExpr
_
g
e
)
=
qfv
m
g
++
qfv
m
e
...
...
@@ -110,18 +110,18 @@ instance QualExpr (Expression a) where
qfv
m
(
LeftSection
_
e
op
)
=
qfv
m
op
++
qfv
m
e
qfv
m
(
RightSection
_
op
e
)
=
qfv
m
op
++
qfv
m
e
qfv
m
(
Lambda
_
ts
e
)
=
filterBv
ts
$
qfv
m
e
qfv
m
(
Let
_
_
ds
e
)
=
filterBv
ds
$
qfv
m
ds
++
qfv
m
e
qfv
m
(
Do
_
_
sts
e
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
sts
qfv
m
(
Let
_
ds
e
)
=
filterBv
ds
$
qfv
m
ds
++
qfv
m
e
qfv
m
(
Do
_
sts
e
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
sts
qfv
m
(
IfThenElse
_
e1
e2
e3
)
=
qfv
m
e1
++
qfv
m
e2
++
qfv
m
e3
qfv
m
(
Case
_
_
_
e
alts
)
=
qfv
m
e
++
qfv
m
alts
qfv
m
(
Case
_
_
e
alts
)
=
qfv
m
e
++
qfv
m
alts
qfvStmt
::
ModuleIdent
->
(
Statement
a
)
->
[
Ident
]
->
[
Ident
]
qfvStmt
m
st
fvs
=
qfv
m
st
++
filterBv
st
fvs
instance
QualExpr
(
Statement
a
)
where
qfv
m
(
StmtExpr
_
e
)
=
qfv
m
e
qfv
m
(
StmtDecl
_
_
ds
)
=
filterBv
ds
$
qfv
m
ds
qfv
m
(
StmtBind
_
_
e
)
=
qfv
m
e
qfv
m
(
StmtExpr
_
e
)
=
qfv
m
e
qfv
m
(
StmtDecl
_
ds
)
=
filterBv
ds
$
qfv
m
ds
qfv
m
(
StmtBind
_
_
e
)
=
qfv
m
e
instance
QualExpr
(
Alt
a
)
where
qfv
m
(
Alt
_
t
rhs
)
=
filterBv
t
$
qfv
m
rhs
...
...
@@ -136,9 +136,9 @@ instance QualExpr a => QualExpr (Field a) where
qfv
m
(
Field
_
_
t
)
=
qfv
m
t
instance
QuantExpr
(
Statement
a
)
where
bv
(
StmtExpr
_
_
)
=
[]
bv
(
StmtBind
_
t
_
)
=
bv
t
bv
(
StmtDecl
_
_
ds
)
=
bv
ds
bv
(
StmtExpr
_
_
)
=
[]
bv
(
StmtBind
_
t
_
)
=
bv
t
bv
(
StmtDecl
_
ds
)
=
bv
ds
instance
QualExpr
(
InfixOp
a
)
where
qfv
m
(
InfixOp
a
op
)
=
qfv
m
$
Variable
NoSpanInfo
a
op
...
...
@@ -182,6 +182,12 @@ instance Expr Constraint where
instance
QuantExpr
Constraint
where
bv
_
=
[]
instance
Expr
QualTypeExpr
where
fv
(
QualTypeExpr
_
_
ty
)
=
fv
ty
instance
QuantExpr
QualTypeExpr
where
bv
(
QualTypeExpr
_
_
ty
)
=
bv
ty
instance
Expr
TypeExpr
where
fv
(
ConstructorType
_
_
)
=
[]
fv
(
ApplyType
_
ty1
ty2
)
=
fv
ty1
++
fv
ty2
...
...
@@ -190,7 +196,6 @@ instance Expr TypeExpr where
fv
(
ListType
_
ty
)
=
fv
ty
fv
(
ArrowType
_
ty1
ty2
)
=
fv
ty1
++
fv
ty2
fv
(
ParenType
_
ty
)
=
fv
ty
fv
(
ContextType
_
_
ty
)
=
fv
ty
fv
(
ForallType
_
vs
ty
)
=
filter
(`
notElem
`
vs
)
$
fv
ty
instance
QuantExpr
TypeExpr
where
...
...
@@ -201,7 +206,6 @@ instance QuantExpr TypeExpr where
bv
(
ListType
_
ty
)
=
bv
ty
bv
(
ArrowType
_
ty1
ty2
)
=
bv
ty1
++
bv
ty2
bv
(
ParenType
_
ty
)
=
bv
ty
bv
(
ContextType
_
_
ty
)
=
bv
ty
bv
(
ForallType
_
tvs
ty
)
=
tvs
++
bv
ty
filterBv
::
QuantExpr
e
=>
e
->
[
Ident
]
->
[
Ident
]
...
...
src/Base/PrettyKinds.hs
View file @
08cc34f2
...
...
@@ -10,7 +10,7 @@
TODO
-}
{-# OPTIONS_GHC -Wno-orphans #-}
module
Base.PrettyKinds
where
import
Curry.Base.Pretty
...
...
src/Base/PrettyTypes.hs
View file @
08cc34f2
...
...
@@ -10,33 +10,39 @@
TODO
-}
{-#
OPTIONS_GHC -Wno-orphans
#-}
{-#
LANGUAGE CPP
#-}
module
Base.PrettyTypes
where
#
if
__GLASGOW_HASKELL__
>=
804
import
Prelude
hiding
((
<>
))
#
endif
import
Data.Maybe
(
fromMaybe
)
import
qualified
Data.Set
as
Set
(
Set
,
toAscList
)
import
Curry.Base.Ident
(
identSupply
)
import
Curry.Base.Ident
(
identSupply
)
import
Curry.Base.Pretty
import
Curry.Syntax.Pretty
()
import
Curry.Syntax.Pretty
import
Base.CurryTypes
import
Base.Types
instance
Pretty
Type
where
pPrint
=
p
PrintPrec
0
.
fromType
identSupply
pPrint
=
p
pTypeExpr
0
.
fromType
identSupply
instance
Pretty
Pred
where
pPrint
=
p
Pr
int
.
fromPred
identSupply
pPrint
=
p
pConstra
int
.
fromPred
identSupply
instance
Pretty
a
=>
Pretty
(
Set
.
Set
a
)
where
pPrint
=
parens
.
list
.
map
pPrint
.
Set
.
toAscList
instance
Pretty
PredType
where
pPrint
=
ppQualTypeExpr
.
fromPredType
identSupply
instance
Pretty
DataConstr
where
pPrint
(
DataConstr
i
tys
)
=
pPrint
i
<+>
hsep
(
map
pPrint
tys
)
pPrint
(
RecordConstr
i
ls
tys
)
=
pPrint
i
<+>
braces
(
hsep
(
punctuate
comma
pLs
))
pPrint
(
DataConstr
i
_
_
tys
)
=
pPrint
i
<+>
hsep
(
map
pPrint
tys
)
pPrint
(
RecordConstr
i
_
_
ls
tys
)
=
pPrint
i
<+>
braces
(
hsep
(
punctuate
comma
pLs
))
where
pLs
=
zipWith
(
\
l
ty
->
pPrint
l
<+>
colon
<>
colon
<+>
pPrint
ty
)
ls
tys
...
...
@@ -44,3 +50,9 @@ instance Pretty ClassMethod where
pPrint
(
ClassMethod
f
mar
pty
)
=
pPrint
f
<>
text
"/"
<>
int
(
fromMaybe
0
mar
)
<+>
colon
<>
colon
<+>
pPrint
pty
instance
Pretty
TypeScheme
where
pPrint
(
ForAll
_
ty
)
=
pPrint
ty
instance
Pretty
ExistTypeScheme
where
pPrint
(
ForAllExist
_
_
ty
)
=
pPrint
ty
src/Base/Subst.hs
View file @
08cc34f2
...
...
@@ -19,7 +19,7 @@
module
Base.Subst
(
Subst
(
..
),
IntSubst
(
..
),
idSubst
,
singleSubst
,
bindSubst
,
unbindSubst
,
substToList
,
compose
,
lookupSubst
,
substVar'
,
isubstVar
,
restrictSubstTo
,
substToList
,
compose
,
substVar'
,
isubstVar
,
restrictSubstTo
)
where
import
qualified
Data.Map
as
Map
...
...
@@ -48,9 +48,6 @@ bindSubst v e (Subst comp sigma) = Subst comp $ Map.insert v e sigma
unbindSubst
::
Ord
v
=>
v
->
Subst
v
e
->
Subst
v
e
unbindSubst
v
(
Subst
comp
sigma
)
=
Subst
comp
$
Map
.
delete
v
sigma