Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
ea8e1e39
Commit
ea8e1e39
authored
Sep 05, 2011
by
Björn Peemöller
Browse files
Refactoring of Base
parent
92227c27
Changes
9
Hide whitespace changes
Inline
Side-by-side
src/Base/CurryTypes.lhs
View file @
ea8e1e39
...
...
@@ -13,7 +13,7 @@ order of type variables in the left hand side of a type declaration.
\begin{verbatim}
>
module
Base.CurryTypes
>
(
toQualType
,
toQualTypes
,
toType
,
toTypes
,
toType'
,
fromQualType
,
fromType
>
(
toQualType
,
toQualTypes
,
toType
,
toTypes
,
fromQualType
,
fromType
>
)
where
>
import
Data.List
(
nub
)
...
...
@@ -33,32 +33,36 @@ order of type variables in the left hand side of a type declaration.
>
toQualTypes
m
tvs
=
map
(
qualifyType
m
)
.
toTypes
tvs
>
toType
::
[
Ident
]
->
CS
.
TypeExpr
->
Type
>
toType
tvs
ty
=
toType'
(
Map
.
fromList
(
zip
(
tvs
++
tvs'
)
[
0
..
])
)
ty
>
where
tvs'
=
[
tv
|
tv
<-
nub
(
fv
ty
),
tv
`
notElem
`
tvs
]
>
toType
tvs
ty
=
toType'
(
Map
.
fromList
$
zip
(
tvs
++
newInTy
)
[
0
..
])
ty
>
where
newInTy
=
[
tv
|
tv
<-
nub
(
fv
ty
),
tv
`
notElem
`
tvs
]
>
toTypes
::
[
Ident
]
->
[
CS
.
TypeExpr
]
->
[
Type
]
>
toTypes
tvs
tys
=
map
(
toType'
(
Map
.
fromList
(
zip
(
tvs
++
tvs'
)
[
0
..
]))
)
tys
>
where
tvs'
=
[
tv
|
tv
<-
nub
(
concatMap
fv
tys
),
tv
`
notElem
`
tvs
]
>
toTypes
tvs
tys
=
map
(
toType'
(
Map
.
fromList
$
zip
(
tvs
++
newInTys
)
[
0
..
]))
tys
>
where
newInTys
=
[
tv
|
tv
<-
nub
(
concatMap
fv
tys
),
tv
`
notElem
`
tvs
]
>
toType'
::
Map
.
Map
Ident
Int
->
CS
.
TypeExpr
->
Type
>
toType'
tvs
(
CS
.
ConstructorType
tc
tys
)
=
>
TypeConstructor
tc
(
map
(
toType'
tvs
)
tys
)
>
toType'
tvs
(
CS
.
VariableType
tv
)
=
>
maybe
(
internalError
$
"Base.CurryTypes.toType': "
++
show
tv
)
TypeVariable
(
Map
.
lookup
tv
tvs
)
>
toType'
tvs
(
CS
.
TupleType
tys
)
>
|
null
tys
=
TypeConstructor
(
qualify
unitId
)
[]
>
|
otherwise
=
TypeConstructor
(
qualify
(
tupleId
(
length
tys'
)))
tys'
>
toType'
tvs
(
CS
.
ConstructorType
tc
tys
)
>
=
TypeConstructor
tc
(
map
(
toType'
tvs
)
tys
)
>
toType'
tvs
(
CS
.
VariableType
tv
)
=
case
Map
.
lookup
tv
tvs
of
>
Just
tv'
->
TypeVariable
tv'
>
Nothing
->
internalError
$
"Base.CurryTypes.toType': "
++
show
tv
>
toType'
tvs
(
CS
.
TupleType
tys
)
>
|
null
tys
=
TypeConstructor
(
qualify
unitId
)
[]
>
|
otherwise
=
TypeConstructor
(
qualify
$
tupleId
$
length
tys'
)
tys'
>
where
tys'
=
map
(
toType'
tvs
)
tys
>
toType'
tvs
(
CS
.
ListType
ty
)
=
TypeConstructor
(
qualify
listId
)
[
toType'
tvs
ty
]
>
toType'
tvs
(
CS
.
ArrowType
ty1
ty2
)
=
>
TypeArrow
(
toType'
tvs
ty1
)
(
toType'
tvs
ty2
)
>
toType'
tvs
(
CS
.
RecordType
fs
rty
)
=
>
TypeRecord
(
concatMap
(
\
(
ls
,
ty
)
->
map
(
\
l
->
(
l
,
toType'
tvs
ty
))
ls
)
fs
)
>
(
maybe
Nothing
>
(
\
ty
->
case
toType'
tvs
ty
of
>
TypeVariable
tv
->
Just
tv
>
_
->
internalError
(
"Base.CurryTypes.toType' "
++
show
ty
))
>
rty
)
>
toType'
tvs
(
CS
.
ListType
ty
)
>
=
TypeConstructor
(
qualify
listId
)
[
toType'
tvs
ty
]
>
toType'
tvs
(
CS
.
ArrowType
ty1
ty2
)
>
=
TypeArrow
(
toType'
tvs
ty1
)
(
toType'
tvs
ty2
)
>
toType'
tvs
(
CS
.
RecordType
fs
rty
)
>
=
TypeRecord
fs'
rty'
>
where
>
fs'
=
concatMap
(
\
(
ls
,
ty
)
->
map
(
\
l
->
(
l
,
toType'
tvs
ty
))
ls
)
fs
>
rty'
=
case
rty
of
>
Nothing
->
Nothing
>
Just
ty
->
case
toType'
tvs
ty
of
>
TypeVariable
tv
->
Just
tv
>
_
->
internalError
$
"Base.CurryTypes.toType' "
++
show
ty
>
fromQualType
::
ModuleIdent
->
Type
->
CS
.
TypeExpr
>
fromQualType
m
=
fromType
.
unqualifyType
m
...
...
@@ -66,16 +70,16 @@ order of type variables in the left hand side of a type declaration.
>
fromType
::
Type
->
CS
.
TypeExpr
>
fromType
(
TypeConstructor
tc
tys
)
>
|
isTupleId
c
=
CS
.
TupleType
tys'
>
|
c
==
listId
&&
length
tys
==
1
=
CS
.
ListType
(
head
tys'
)
>
|
c
==
unitId
&&
null
tys
=
CS
.
TupleType
[]
>
|
c
==
listId
&&
length
tys
==
1
=
CS
.
ListType
(
head
tys'
)
>
|
otherwise
=
CS
.
ConstructorType
tc
tys'
>
where
c
=
unqualify
tc
>
tys'
=
map
fromType
tys
>
fromType
(
TypeVariable
tv
)
=
CS
.
VariableType
>
(
if
tv
>=
0
then
identSupply
!!
tv
else
mkIdent
(
'_'
:
show
(
-
tv
)))
>
fromType
(
TypeConstrained
tys
_
)
=
fromType
(
head
tys
)
>
fromType
(
TypeArrow
ty1
ty2
)
=
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
>
fromType
(
TypeSkolem
k
)
=
CS
.
VariableType
(
mkIdent
(
"_?"
++
show
k
))
>
fromType
(
TypeRecord
fs
rty
)
=
CS
.
RecordType
>
fromType
(
TypeArrow
ty1
ty2
)
=
CS
.
ArrowType
(
fromType
ty1
)
(
fromType
ty2
)
>
fromType
(
TypeSkolem
k
)
=
CS
.
VariableType
$
mkIdent
$
"_?"
++
show
k
>
fromType
(
TypeRecord
fs
rty
)
=
CS
.
RecordType
>
(
map
(
\
(
l
,
ty
)
->
([
l
],
fromType
ty
))
fs
)
>
(
maybe
Nothing
(
Just
.
fromType
.
TypeVariable
)
rty
)
>
(
(
fromType
.
TypeVariable
)
`
fmap
`
rty
)
src/Base/Expr.hs
View file @
ea8e1e39
{- |Free and bound variables
The compiler needs to compute the sets of free and bound variables for
{- |
Module : $Header$
Description : Extraction of free and bound variables
Copyright : (c) Wolfgang Lux
2011, Björn Peemöller (bjp@informatik.uni-kiel.de)
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The compiler needs to compute the lists of free and bound variables for
various different entities. We will devote three type classes to that
purpose. The \texttt{QualExpr} class is expected to take into account
that it is possible to use a qualified name to refer to a function
defined in the current module and therefore \emph{M.x} and $x$, where
$M$ is the current module name, should be considered the same name.
However note that this is correct only after renaming all local
However
,
note that this is correct only after renaming all local
definitions as \emph{M.x} always denotes an entity defined at the
top-level.
-}
...
...
@@ -18,12 +27,15 @@ import Curry.Base.Ident
import
Curry.Syntax
class
Expr
e
where
-- |Free variables in an 'Expr'
fv
::
e
->
[
Ident
]
class
QualExpr
e
where
-- |Free qualified variables in an 'Expr'
qfv
::
ModuleIdent
->
e
->
[
Ident
]
class
QuantExpr
e
where
-- |Bound variables in an 'Expr'
bv
::
e
->
[
Ident
]
instance
Expr
e
=>
Expr
[
e
]
where
...
...
@@ -46,72 +58,72 @@ instance QuantExpr e => QuantExpr [e] where
instance
QualExpr
Decl
where
qfv
m
(
FunctionDecl
_
_
eqs
)
=
qfv
m
eqs
qfv
m
(
PatternDecl
_
_
rhs
)
=
qfv
m
rhs
qfv
_
_
=
[]
qfv
m
(
PatternDecl
_
_
rhs
)
=
qfv
m
rhs
qfv
_
_
=
[]
instance
QuantExpr
Decl
where
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
EvalAnnot
_
fs
_
)
=
fs
bv
(
FunctionDecl
_
f
_
)
=
[
f
]
bv
(
TypeSig
_
vs
_
)
=
vs
bv
(
EvalAnnot
_
fs
_
)
=
fs
bv
(
FunctionDecl
_
f
_
)
=
[
f
]
bv
(
ExternalDecl
_
_
_
f
_
)
=
[
f
]
bv
(
FlatExternalDecl
_
fs
)
=
fs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
ExtraVariables
_
vs
)
=
vs
bv
_
=
[]
bv
(
FlatExternalDecl
_
fs
)
=
fs
bv
(
PatternDecl
_
t
_
)
=
bv
t
bv
(
ExtraVariables
_
vs
)
=
vs
bv
_
=
[]
instance
QualExpr
Equation
where
qfv
m
(
Equation
_
lhs
rhs
)
=
filterBv
lhs
(
qfv
m
lhs
++
qfv
m
rhs
)
qfv
m
(
Equation
_
lhs
rhs
)
=
filterBv
lhs
$
qfv
m
lhs
++
qfv
m
rhs
instance
QuantExpr
Lhs
where
bv
=
bv
.
snd
.
flatLhs
instance
QualExpr
Lhs
where
qfv
m
lhs
=
qfv
m
(
snd
(
flatLhs
lhs
))
qfv
m
lhs
=
qfv
m
$
snd
$
flatLhs
lhs
instance
QualExpr
Rhs
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
where
qfv
m
(
CondExpr
_
g
e
)
=
qfv
m
g
++
qfv
m
e
instance
QualExpr
Expression
where
qfv
_
(
Literal
_
)
=
[]
qfv
m
(
Variable
v
)
=
maybe
[]
return
(
localIdent
m
v
)
qfv
_
(
Constructor
_
)
=
[]
qfv
m
(
Paren
e
)
=
qfv
m
e
qfv
m
(
Typed
e
_
)
=
qfv
m
e
qfv
m
(
Tuple
_
es
)
=
qfv
m
es
qfv
m
(
List
_
es
)
=
qfv
m
es
qfv
m
(
ListCompr
_
e
qs
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
qs
qfv
m
(
EnumFrom
e
)
=
qfv
m
e
qfv
m
(
EnumFromThen
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
m
(
EnumFromTo
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
_
(
Literal
_
)
=
[]
qfv
m
(
Variable
v
)
=
maybe
[]
return
$
localIdent
m
v
qfv
_
(
Constructor
_
)
=
[]
qfv
m
(
Paren
e
)
=
qfv
m
e
qfv
m
(
Typed
e
_
)
=
qfv
m
e
qfv
m
(
Tuple
_
es
)
=
qfv
m
es
qfv
m
(
List
_
es
)
=
qfv
m
es
qfv
m
(
ListCompr
_
e
qs
)
=
foldr
(
qfvStmt
m
)
(
qfv
m
e
)
qs
qfv
m
(
EnumFrom
e
)
=
qfv
m
e
qfv
m
(
EnumFromThen
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
m
(
EnumFromTo
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
m
(
EnumFromThenTo
e1
e2
e3
)
=
qfv
m
e1
++
qfv
m
e2
++
qfv
m
e3
qfv
m
(
UnaryMinus
_
e
)
=
qfv
m
e
qfv
m
(
Apply
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
m
(
InfixApply
e1
op
e2
)
=
qfv
m
op
++
qfv
m
e1
++
qfv
m
e2
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
(
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
(
RecordConstr
fs
)
=
qfv
m
fs
qfv
m
(
RecordSelection
e
_
)
=
qfv
m
e
qfv
m
(
RecordUpdate
fs
e
)
=
qfv
m
e
++
qfv
m
fs
qfv
m
(
UnaryMinus
_
e
)
=
qfv
m
e
qfv
m
(
Apply
e1
e2
)
=
qfv
m
e1
++
qfv
m
e2
qfv
m
(
InfixApply
e1
op
e2
)
=
qfv
m
op
++
qfv
m
e1
++
qfv
m
e2
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
(
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
(
RecordConstr
fs
)
=
qfv
m
fs
qfv
m
(
RecordSelection
e
_
)
=
qfv
m
e
qfv
m
(
RecordUpdate
fs
e
)
=
qfv
m
e
++
qfv
m
fs
qfvStmt
::
ModuleIdent
->
Statement
->
[
Ident
]
->
[
Ident
]
qfvStmt
m
st
fvs
=
qfv
m
st
++
filterBv
st
fvs
instance
QualExpr
Statement
where
qfv
m
(
StmtExpr
_
e
)
=
qfv
m
e
qfv
m
(
StmtDecl
ds
)
=
filterBv
ds
(
qfv
m
ds
)
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
where
qfv
m
(
Alt
_
t
rhs
)
=
filterBv
t
(
qfv
m
rhs
)
qfv
m
(
Alt
_
t
rhs
)
=
filterBv
t
$
qfv
m
rhs
instance
QuantExpr
a
=>
QuantExpr
(
Field
a
)
where
bv
(
Field
_
_
t
)
=
bv
t
...
...
@@ -120,55 +132,55 @@ instance QualExpr a => QualExpr (Field a) where
qfv
m
(
Field
_
_
t
)
=
qfv
m
t
instance
QuantExpr
Statement
where
bv
(
StmtExpr
_
_
)
=
[]
bv
(
StmtExpr
_
_
)
=
[]
bv
(
StmtBind
_
t
_
)
=
bv
t
bv
(
StmtDecl
ds
)
=
bv
ds
bv
(
StmtDecl
ds
)
=
bv
ds
instance
QualExpr
InfixOp
where
qfv
m
(
InfixOp
op
)
=
qfv
m
(
Variable
op
)
qfv
m
(
InfixOp
op
)
=
qfv
m
$
Variable
op
qfv
_
(
InfixConstr
_
)
=
[]
instance
QuantExpr
ConstrTerm
where
bv
(
LiteralPattern
_
)
=
[]
bv
(
NegativePattern
_
_
)
=
[]
bv
(
VariablePattern
v
)
=
[
v
]
bv
(
ConstructorPattern
_
ts
)
=
bv
ts
bv
(
InfixPattern
t1
_
t2
)
=
bv
t1
++
bv
t2
bv
(
ParenPattern
t
)
=
bv
t
bv
(
TuplePattern
_
ts
)
=
bv
ts
bv
(
ListPattern
_
ts
)
=
bv
ts
bv
(
AsPattern
v
t
)
=
v
:
bv
t
bv
(
LazyPattern
_
t
)
=
bv
t
bv
(
FunctionPattern
f
ts
)
=
bvFuncPatt
(
FunctionPattern
f
ts
)
bv
(
InfixFuncPattern
t1
op
t2
)
=
bvFuncPatt
(
InfixFuncPattern
t1
op
t2
)
bv
(
RecordPattern
fs
r
)
=
maybe
[]
bv
r
++
bv
fs
bv
(
LiteralPattern
_
)
=
[]
bv
(
NegativePattern
_
_
)
=
[]
bv
(
VariablePattern
v
)
=
[
v
]
bv
(
ConstructorPattern
_
ts
)
=
bv
ts
bv
(
InfixPattern
t1
_
t2
)
=
bv
t1
++
bv
t2
bv
(
ParenPattern
t
)
=
bv
t
bv
(
TuplePattern
_
ts
)
=
bv
ts
bv
(
ListPattern
_
ts
)
=
bv
ts
bv
(
AsPattern
v
t
)
=
v
:
bv
t
bv
(
LazyPattern
_
t
)
=
bv
t
bv
(
FunctionPattern
f
ts
)
=
bvFuncPatt
$
FunctionPattern
f
ts
bv
(
InfixFuncPattern
t1
op
t2
)
=
bvFuncPatt
$
InfixFuncPattern
t1
op
t2
bv
(
RecordPattern
fs
r
)
=
maybe
[]
bv
r
++
bv
fs
instance
QualExpr
ConstrTerm
where
qfv
_
(
LiteralPattern
_
)
=
[]
qfv
_
(
NegativePattern
_
_
)
=
[]
qfv
_
(
VariablePattern
_
)
=
[]
qfv
m
(
ConstructorPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
InfixPattern
t1
_
t2
)
=
qfv
m
[
t1
,
t2
]
qfv
m
(
ParenPattern
t
)
=
qfv
m
t
qfv
m
(
TuplePattern
_
ts
)
=
qfv
m
ts
qfv
m
(
ListPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
AsPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
LazyPattern
_
t
)
=
qfv
m
t
qfv
m
(
FunctionPattern
f
ts
)
qfv
_
(
LiteralPattern
_
)
=
[]
qfv
_
(
NegativePattern
_
_
)
=
[]
qfv
_
(
VariablePattern
_
)
=
[]
qfv
m
(
ConstructorPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
InfixPattern
t1
_
t2
)
=
qfv
m
[
t1
,
t2
]
qfv
m
(
ParenPattern
t
)
=
qfv
m
t
qfv
m
(
TuplePattern
_
ts
)
=
qfv
m
ts
qfv
m
(
ListPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
AsPattern
_
ts
)
=
qfv
m
ts
qfv
m
(
LazyPattern
_
t
)
=
qfv
m
t
qfv
m
(
FunctionPattern
f
ts
)
=
maybe
[]
return
(
localIdent
m
f
)
++
qfv
m
ts
qfv
m
(
InfixFuncPattern
t1
op
t2
)
=
maybe
[]
return
(
localIdent
m
op
)
++
qfv
m
[
t1
,
t2
]
qfv
m
(
RecordPattern
fs
r
)
=
maybe
[]
(
qfv
m
)
r
++
qfv
m
fs
qfv
m
(
RecordPattern
fs
r
)
=
maybe
[]
(
qfv
m
)
r
++
qfv
m
fs
instance
Expr
TypeExpr
where
fv
(
ConstructorType
_
tys
)
=
fv
tys
fv
(
VariableType
tv
)
|
tv
==
anonId
=
[]
|
otherwise
=
[
tv
]
fv
(
TupleType
tys
)
=
fv
tys
fv
(
ListType
ty
)
=
fv
ty
fv
(
ArrowType
ty1
ty2
)
=
fv
ty1
++
fv
ty2
fv
(
RecordType
fs
rty
)
=
maybe
[]
fv
rty
++
fv
(
map
snd
fs
)
fv
(
VariableType
tv
)
|
tv
==
anonId
=
[]
|
otherwise
=
[
tv
]
fv
(
TupleType
tys
)
=
fv
tys
fv
(
ListType
ty
)
=
fv
ty
fv
(
ArrowType
ty1
ty2
)
=
fv
ty1
++
fv
ty2
fv
(
RecordType
fs
rty
)
=
maybe
[]
fv
rty
++
fv
(
map
snd
fs
)
filterBv
::
QuantExpr
e
=>
e
->
[
Ident
]
->
[
Ident
]
filterBv
e
=
filter
(`
Set
.
notMember
`
Set
.
fromList
(
bv
e
))
...
...
@@ -181,21 +193,21 @@ filterBv e = filter (`Set.notMember` Set.fromList (bv e))
bvFuncPatt
::
ConstrTerm
->
[
Ident
]
bvFuncPatt
=
bvfp
[]
where
bvfp
bvs
(
LiteralPattern
_
)
=
bvs
bvfp
bvs
(
NegativePattern
_
_
)
=
bvs
bvfp
bvs
(
VariablePattern
v
)
|
v
`
elem
`
bvs
=
bvs
|
otherwise
=
v
:
bvs
bvfp
bvs
(
ConstructorPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
InfixPattern
t1
_
t2
)
=
foldl
bvfp
bvs
[
t1
,
t2
]
bvfp
bvs
(
ParenPattern
t
)
=
bvfp
bvs
t
bvfp
bvs
(
TuplePattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
ListPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
AsPattern
v
t
)
|
v
`
elem
`
bvs
=
bvfp
bvs
t
|
otherwise
=
bvfp
(
v
:
bvs
)
t
bvfp
bvs
(
LazyPattern
_
t
)
=
bvfp
bvs
t
bvfp
bvs
(
FunctionPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
LiteralPattern
_
)
=
bvs
bvfp
bvs
(
NegativePattern
_
_
)
=
bvs
bvfp
bvs
(
VariablePattern
v
)
|
v
`
elem
`
bvs
=
bvs
|
otherwise
=
v
:
bvs
bvfp
bvs
(
ConstructorPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
InfixPattern
t1
_
t2
)
=
foldl
bvfp
bvs
[
t1
,
t2
]
bvfp
bvs
(
ParenPattern
t
)
=
bvfp
bvs
t
bvfp
bvs
(
TuplePattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
ListPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
AsPattern
v
t
)
|
v
`
elem
`
bvs
=
bvfp
bvs
t
|
otherwise
=
bvfp
(
v
:
bvs
)
t
bvfp
bvs
(
LazyPattern
_
t
)
=
bvfp
bvs
t
bvfp
bvs
(
FunctionPattern
_
ts
)
=
foldl
bvfp
bvs
ts
bvfp
bvs
(
InfixFuncPattern
t1
_
t2
)
=
foldl
bvfp
bvs
[
t1
,
t2
]
bvfp
bvs
(
RecordPattern
fs
r
)
bvfp
bvs
(
RecordPattern
fs
r
)
=
foldl
bvfp
(
maybe
bvs
(
bvfp
bvs
)
r
)
(
map
fieldTerm
fs
)
src/Base/Messages.hs
View file @
ea8e1e39
module
Base.Messages
(
info
,
status
,
putErrLn
,
putErrsLn
,
abortWith
,
internalError
,
errorAt
,
errorAt'
,
internalError
,
errorAt
,
errorAt'
,
errorMessages
,
Message
,
toMessage
,
posErr
,
qposErr
)
where
import
Control.Monad
(
unless
)
import
System.IO
(
hPutStrLn
,
stderr
)
import
System.Exit
(
ExitCode
(
..
),
exitWith
)
import
Curry.Base.Ident
(
Ident
,
QualIdent
,
positionOfIdent
,
positionOfQualIdent
)
import
Curry.Base.MessageMonad
(
Message
,
toMessage
)
import
Curry.Base.Position
(
Position
)
import
CompilerOpts
(
Options
(
optVerbosity
),
Verbosity
(
..
))
...
...
@@ -32,12 +35,21 @@ abortWith errs = putErrsLn errs >> exitWith (ExitFailure 1)
-- |Raise an internal error
internalError
::
String
->
a
internalError
msg
=
error
$
"
i
nternal error: "
++
msg
internalError
msg
=
error
$
"
I
nternal error: "
++
msg
-- |Raise an error for a given position
errorAt
::
Position
->
String
->
a
errorAt
p
msg
=
error
(
"
\n
"
++
show
p
++
": "
++
msg
)
errorAt
p
msg
=
error
(
'
\n
'
:
(
show
$
toMessage
p
msg
)
)
-- |Raise an error for a given position, uncurried
errorAt'
::
(
Position
,
String
)
->
a
errorAt'
=
uncurry
errorAt
errorMessages
::
[
Message
]
->
a
errorMessages
=
error
.
unlines
.
map
show
posErr
::
Ident
->
String
->
Message
posErr
i
errMsg
=
toMessage
(
positionOfIdent
i
)
errMsg
qposErr
::
QualIdent
->
String
->
Message
qposErr
i
errMsg
=
toMessage
(
positionOfQualIdent
i
)
errMsg
src/Base/Subst.lhs
View file @
ea8e1e39
...
...
@@ -24,14 +24,14 @@ marked with a boolean flag (see below).
>
idSubst
::
Ord
a
=>
Subst
a
b
>
idSubst
=
Subst
False
Map
.
empty
>
substToList
::
Ord
v
=>
Subst
v
e
->
[(
v
,
e
)]
>
substToList
::
Ord
v
=>
Subst
v
e
->
[(
v
,
e
)]
>
substToList
(
Subst
_
sigma
)
=
Map
.
toList
sigma
>
bindSubst
::
Ord
v
=>
v
->
e
->
Subst
v
e
->
Subst
v
e
>
bindSubst
v
e
(
Subst
comp
sigma
)
=
Subst
comp
(
Map
.
insert
v
e
sigma
)
>
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
)
>
unbindSubst
v
(
Subst
comp
sigma
)
=
Subst
comp
$
Map
.
delete
v
sigma
\end{verbatim}
For any substitution we have the following definitions:
...
...
@@ -83,7 +83,7 @@ substVar :: Subst v e => Subst v e -> v -> e
substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma)
where subst' = if comp then subst (Subst comp sigma) else id
>
compose
::
(
Show
v
,
Ord
v
,
Show
e
)
=>
Subst
v
e
->
Subst
v
e
->
Subst
v
e
>
compose
::
(
Ord
v
,
Show
v
,
Show
e
)
=>
Subst
v
e
->
Subst
v
e
->
Subst
v
e
>
compose
sigma
sigma'
=
>
composed
(
foldr
(
uncurry
bindSubst
)
sigma'
(
substToList
sigma
))
>
where
composed
(
Subst
_
sigma''
)
=
Subst
True
sigma''
...
...
src/Base/TopEnv.lhs
View file @
ea8e1e39
...
...
@@ -33,16 +33,16 @@ with an imported entity identify the modules from which the entity was
imported.
\begin{verbatim}
>
module
Env
.TopEnv
>
(
TopEnv
(
..
),
Entity
(
..
),
emptyTopEnv
,
predefTopEnv
,
qualI
mportTopEnv
>
,
i
mportTopEnv
,
bindTopEnv
,
qualBindTopEnv
,
rebindTopEnv
,
qualRebindTopEnv
>
,
unbindTopEnv
,
lookupTopEnv
,
qualLookupTopEnv
>
,
allImports
,
moduleImports
,
localBindings
>
module
Base
.TopEnv
>
(
TopEnv
(
..
),
Entity
(
..
),
emptyTopEnv
,
predefTopEnv
,
i
mportTopEnv
>
,
qualI
mportTopEnv
,
bindTopEnv
,
qualBindTopEnv
,
rebindTopEnv
>
,
qualRebindTopEnv
,
unbindTopEnv
,
lookupTopEnv
,
qualLookupTopEnv
>
,
allImports
,
moduleImports
,
localBindings
>
)
where
>
import
Control.Arrow
(
second
)
>
import
qualified
Data.Map
as
Map
>
import
Data.Maybe
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
toList
)
>
import
Data.Maybe
(
fromMaybe
)
>
import
Curry.Base.Ident
>
import
Base.Messages
(
internalError
)
...
...
@@ -62,45 +62,42 @@ imported.
>
instance
Functor
TopEnv
where
>
fmap
f
(
TopEnv
env
)
=
TopEnv
(
fmap
(
map
(
second
f
))
env
)
>
entities
::
QualIdent
->
Map
.
Map
QualIdent
[(
Source
,
a
)]
->
[(
Source
,
a
)]
>
entities
x
env
=
fromMaybe
[]
(
Map
.
lookup
x
env
)
>
entities
::
QualIdent
->
Map
.
Map
QualIdent
[(
Source
,
a
)]
->
[(
Source
,
a
)]
>
entities
x
env
=
fromMaybe
[]
$
Map
.
lookup
x
env
>
emptyTopEnv
::
TopEnv
a
>
emptyTopEnv
=
TopEnv
Map
.
empty
>
predefTopEnv
::
Entity
a
=>
QualIdent
->
a
->
TopEnv
a
->
TopEnv
a
>
predefTopEnv
x
y
(
TopEnv
env
)
=
>
case
Map
.
lookup
x
env
of
>
Just
_
->
internalError
"TopEnv.predefTopEnv"
>
Nothing
->
TopEnv
(
Map
.
insert
x
[(
Import
[]
,
y
)]
env
)
>
predefTopEnv
x
y
(
TopEnv
env
)
=
case
Map
.
lookup
x
env
of
>
Just
_
->
internalError
"TopEnv.predefTopEnv"
>
Nothing
->
TopEnv
$
Map
.
insert
x
[(
Import
[]
,
y
)]
env
>
importTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
importTopEnv
m
x
y
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
)
>
TopEnv
$
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
>
where
x'
=
qualify
x
>
qualImportTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
>
->
TopEnv
a
>
qualImportTopEnv
::
Entity
a
=>
ModuleIdent
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
qualImportTopEnv
m
x
y
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
)
>
TopEnv
$
Map
.
insert
x'
(
mergeImport
m
y
(
entities
x'
env
))
env
>
where
x'
=
qualifyWith
m
x
>
mergeImport
::
Entity
a
=>
ModuleIdent
->
a
->
[(
Source
,
a
)]
->
[(
Source
,
a
)]
>
mergeImport
m
x
[]
=
[(
Import
[
m
],
x
)]
>
mergeImport
m
x
((
Local
,
x'
)
:
xs
)
=
(
Local
,
x'
)
:
mergeImport
m
x
xs
>
mergeImport
m
x
((
Import
ms
,
x'
)
:
xs
)
=
>
case
merge
x
x'
of
>
Just
x''
->
(
Import
(
m
:
ms
),
x''
)
:
xs
>
Nothing
->
(
Import
ms
,
x'
)
:
mergeImport
m
x
xs
>
mergeImport
::
Entity
a
=>
ModuleIdent
->
a
->
[(
Source
,
a
)]
->
[(
Source
,
a
)]
>
mergeImport
m
x
[]
=
[(
Import
[
m
],
x
)]
>
mergeImport
m
x
(
loc
@
(
Local
,
_
)
:
xs
)
=
loc
:
mergeImport
m
x
xs
>
mergeImport
m
x
(
imp
@
(
Import
ms
,
x'
)
:
xs
)
=
case
merge
x
x'
of
>
Just
x''
->
(
Import
(
m
:
ms
),
x''
)
:
xs
>
Nothing
->
imp
:
mergeImport
m
x
xs
>
bindTopEnv
::
String
->
Ident
->
a
->
TopEnv
a
->
TopEnv
a
>
bindTopEnv
fun
x
y
env
=
qualBindTopEnv
fun
(
qualify
x
)
y
env
>
qualBindTopEnv
::
String
->
QualIdent
->
a
->
TopEnv
a
->
TopEnv
a
>
qualBindTopEnv
fun
x
y
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x
(
bindLocal
y
(
entities
x
env
))
env
)
>
TopEnv
$
Map
.
insert
x
(
bindLocal
y
(
entities
x
env
))
env
>
where
bindLocal
y'
ys
>
|
null
[
y''
|
(
Local
,
y''
)
<-
ys
]
=
(
Local
,
y'
)
:
ys
>
|
null
[
y''
|
(
Local
,
y''
)
<-
ys
]
=
(
Local
,
y'
)
:
ys
>
|
otherwise
=
internalError
$
"
\"
qualBindTopEnv "
++
show
x
>
++
"
\"
failed in function
\"
"
++
fun
++
"
\"
"
...
...
@@ -109,18 +106,18 @@ imported.
>
qualRebindTopEnv
::
QualIdent
->
a
->
TopEnv
a
->
TopEnv
a
>
qualRebindTopEnv
x
y
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x
(
rebindLocal
(
entities
x
env
))
env
)
>
where
rebindLocal
[]
=
internalError
"TopEnv.qualRebindTopEnv"
>
rebindLocal
((
Local
,
_
)
:
ys
)
=
(
Local
,
y
)
:
ys
>
rebindLocal
(
(
I
mport
ms
,
y'
)
:
ys
)
=
(
I
mport
ms
,
y'
)
:
rebindLocal
ys
>
TopEnv
$
Map
.
insert
x
(
rebindLocal
(
entities
x
env
))
env
>
where
rebindLocal
[]
=
internalError
"TopEnv.qualRebindTopEnv"
>
rebindLocal
((
Local
,
_
)
:
ys
)
=
(
Local
,
y
)
:
ys
>
rebindLocal
(
i
mport
ed
:
ys
)
=
i
mport
ed
:
rebindLocal
ys
>
unbindTopEnv
::
Ident
->
TopEnv
a
->
TopEnv
a
>
unbindTopEnv
x
(
TopEnv
env
)
=
>
TopEnv
(
Map
.
insert
x'
(
unbindLocal
(
entities
x'
env
))
env
)
>
TopEnv
$
Map
.
insert
x'
(
unbindLocal
(
entities
x'
env
))
env
>
where
x'
=
qualify
x
>
unbindLocal
[]
=
internalError
"TopEnv.unbindTopEnv"
>
unbindLocal
((
Local
,
_
)
:
ys
)
=
ys
>
unbindLocal
(
(
I
mport
ms
,
y
)
:
ys
)
=
(
I
mport
ms
,
y
)
:
unbindLocal
ys
>
unbindLocal
((
Local
,
_
)
:
ys
)
=
ys
>
unbindLocal
(
i
mport
ed
:
ys
)
=
i
mport
ed
:
unbindLocal
ys
>
lookupTopEnv
::
Ident
->
TopEnv
a
->
[
a
]
>
lookupTopEnv
=
qualLookupTopEnv
.
qualify
...
...
@@ -128,20 +125,20 @@ imported.
>
qualLookupTopEnv
::
QualIdent
->
TopEnv
a
->
[
a
]
>
qualLookupTopEnv
x
(
TopEnv
env
)
=
map
snd
(
entities
x
env
)
>
allImports
::
TopEnv
a
->
[(
QualIdent
,
a
)]
>
allImports
::
TopEnv
a
->
[(
QualIdent
,
a
)]
>
allImports
(
TopEnv
env
)
=
>
[(
x
,
y
)
|
(
x
,
ys
)
<-
Map
.
toList
env
,
(
Import
_
,
y
)
<-
ys
]
>
[
(
x
,
y
)
|
(
x
,
ys
)
<-
Map
.
toList
env
,
(
Import
_
,
y
)
<-
ys
]
>
unqualBindings
::
TopEnv
a
->
[(
Ident
,(
Source
,
a
))]
>
unqualBindings
::
TopEnv
a
->
[(
Ident
,
(
Source
,
a
))]
>
unqualBindings
(
TopEnv
env
)
=
>
[(
x'
,
y
)
|
(
x
,
ys
)
<-
takeWhile
(
not
.
isQualified
.
fst
)
(
Map
.
toList
env
)
,
>
let
x'
=
unqualify
x
,
y
<-
ys
]
>
[(
x'
,
y
)
|
(
x
,
ys
)
<-
takeWhile
(
not
.
isQualified
.
fst
)
(
Map
.
toList
env
)
>
,
let
x'
=
unqualify
x
,
y
<-
ys
]
>
moduleImports
::
ModuleIdent
->
TopEnv
a
->
[(
Ident
,
a
)]