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
43f6528a
Commit
43f6528a
authored
Mar 29, 2012
by
Björn Peemöller
Browse files
Adapted renamings in curry-base
parent
fabe4f47
Changes
27
Hide whitespace changes
Inline
Side-by-side
src/Base/Messages.hs
View file @
43f6528a
...
...
@@ -11,8 +11,7 @@ import Control.Monad (unless)
import
System.IO
(
hPutStrLn
,
stderr
)
import
System.Exit
(
ExitCode
(
..
),
exitWith
)
import
Curry.Base.Ident
(
ModuleIdent
(
..
),
Ident
(
..
),
QualIdent
,
positionOfQualIdent
)
import
Curry.Base.Ident
(
ModuleIdent
(
..
),
Ident
(
..
),
QualIdent
,
qidPosition
)
import
Curry.Base.MessageMonad
(
Message
,
toMessage
)
import
CompilerOpts
(
Options
(
optVerbosity
),
Verbosity
(
..
))
...
...
@@ -48,10 +47,10 @@ errorMessages :: [Message] -> a
errorMessages
=
error
.
unlines
.
map
show
posErr
::
Ident
->
String
->
Message
posErr
i
errMsg
=
toMessage
(
p
osition
OfIdent
i
)
errMsg
posErr
i
errMsg
=
toMessage
(
idP
osition
i
)
errMsg
qposErr
::
QualIdent
->
String
->
Message
qposErr
i
errMsg
=
toMessage
(
p
osition
OfQualIdent
i
)
errMsg
qposErr
i
errMsg
=
toMessage
(
qidP
osition
i
)
errMsg
mposErr
::
ModuleIdent
->
String
->
Message
mposErr
m
errMsg
=
toMessage
(
p
osition
OfModuleIdent
m
)
errMsg
mposErr
m
errMsg
=
toMessage
(
midP
osition
m
)
errMsg
src/Base/OldScopeEnv.hs
View file @
43f6528a
...
...
@@ -12,11 +12,11 @@ type IdEnv = Map.Map IdRep Integer
data
IdRep
=
Name
String
|
Index
Integer
deriving
(
Eq
,
Ord
)
insertId
::
Integer
->
Ident
->
IdEnv
->
IdEnv
insertId
level
ident
=
Map
.
insert
(
Name
(
n
ame
ident
))
level
.
Map
.
insert
(
Index
(
u
nique
Id
ident
))
level
insertId
level
ident
=
Map
.
insert
(
Name
(
idN
ame
ident
))
level
.
Map
.
insert
(
Index
(
idU
nique
ident
))
level
nameExists
::
String
->
IdEnv
->
Bool
nameExists
idN
ame
=
Map
.
member
(
Name
idN
ame
)
nameExists
n
ame
=
Map
.
member
(
Name
n
ame
)
indexExists
::
Integer
->
IdEnv
->
Bool
indexExists
index
=
Map
.
member
(
Index
index
)
...
...
@@ -57,7 +57,7 @@ beginScope (topleveltab, leveltabs, level) = case leveltabs of
-- the prefix 'name' followed by an index (i.e. "var3" if 'name' was "var").
-- All returned identifiers are unique within the current scope.
genIdentList
::
Int
->
String
->
ScopeEnv
->
[
Ident
]
genIdentList
size
idN
ame
scopeenv
=
p_genIdentList
size
idN
ame
scopeenv
0
genIdentList
size
n
ame
scopeenv
=
p_genIdentList
size
n
ame
scopeenv
0
where
p_genIdentList
::
Int
->
String
->
ScopeEnv
->
Int
->
[
Ident
]
p_genIdentList
s
n
env
i
...
...
@@ -73,9 +73,9 @@ genIdentList size idName scopeenv = p_genIdentList size idName scopeenv 0
-- unique within the current scope. If no identifier can be generated for
-- 'name' then 'Nothing' will be returned
genIdent
::
String
->
ScopeEnv
->
Maybe
Ident
genIdent
idN
ame
(
topleveltab
,
leveltabs
,
_
)
=
case
leveltabs
of
[]
->
genId
idN
ame
topleveltab
(
lt
:
_
)
->
genId
idN
ame
lt
genIdent
n
ame
(
topleveltab
,
leveltabs
,
_
)
=
case
leveltabs
of
[]
->
genId
n
ame
topleveltab
(
lt
:
_
)
->
genId
n
ame
lt
-- -- Return the declaration level of an identifier if it exists
-- getIdentLevel :: Ident -> ScopeEnv -> Maybe Integer
...
...
src/Checks/ExportCheck.hs
View file @
43f6528a
...
...
@@ -254,17 +254,17 @@ errMultipleExportType :: [Ident] -> Message
errMultipleExportType
[]
=
internalError
"Checks.ExportCheck.errMultipleExportType: empty list"
errMultipleExportType
(
i
:
is
)
=
posErr
i
$
"Multiple exports of type "
++
n
ame
i
++
" at:
\n
"
"Multiple exports of type "
++
idN
ame
i
++
" at:
\n
"
++
unlines
(
map
showPos
(
i
:
is
))
where
showPos
=
(
" "
++
)
.
showLine
.
p
osition
OfIdent
where
showPos
=
(
" "
++
)
.
showLine
.
idP
osition
errMultipleExportValue
::
[
Ident
]
->
Message
errMultipleExportValue
[]
=
internalError
"Checks.ExportCheck.errMultipleExportValue: empty list"
errMultipleExportValue
(
i
:
is
)
=
posErr
i
$
"Multiple exports of "
++
n
ame
i
++
" at:
\n
"
"Multiple exports of "
++
idN
ame
i
++
" at:
\n
"
++
unlines
(
map
showPos
(
i
:
is
))
where
showPos
=
(
" "
++
)
.
showLine
.
p
osition
OfIdent
where
showPos
=
(
" "
++
)
.
showLine
.
idP
osition
errAmbiguousType
::
QualIdent
->
Message
errAmbiguousType
tc
=
qposErr
tc
$
"Ambiguous type "
++
qualName
tc
...
...
@@ -281,8 +281,8 @@ errNonDataType tc = qposErr tc $ qualName tc ++ " is not a data type"
errUndefinedDataConstr
::
QualIdent
->
Ident
->
Message
errUndefinedDataConstr
tc
c
=
posErr
c
$
n
ame
c
++
" is not a data constructor of type "
++
qualName
tc
idN
ame
c
++
" is not a data constructor of type "
++
qualName
tc
errUndefinedLabel
::
QualIdent
->
Ident
->
Message
errUndefinedLabel
r
l
=
posErr
l
$
n
ame
l
++
" is not a label of the record "
++
qualName
r
idN
ame
l
++
" is not a label of the record "
++
qualName
r
src/Checks/KindCheck.lhs
View file @
43f6528a
...
...
@@ -323,16 +323,16 @@ Error messages:
>
errMultipleDeclaration
[]
=
internalError
>
"KindCheck.errMultipleDeclaration: empty list"
>
errMultipleDeclaration
(
i
:
is
)
=
posErr
i
$
>
"Multiple declarations for type `"
++
n
ame
i
++
"` at:
\n
"
>
"Multiple declarations for type `"
++
idN
ame
i
++
"` at:
\n
"
>
++
unlines
(
map
showPos
(
i
:
is
))
>
where
showPos
=
(
" "
++
)
.
showLine
.
p
osition
OfIdent
>
where
showPos
=
(
" "
++
)
.
showLine
.
idP
osition
>
errNonLinear
::
Ident
->
Message
>
errNonLinear
tv
=
posErr
tv
$
"Type variable "
++
n
ame
tv
++
>
errNonLinear
tv
=
posErr
tv
$
"Type variable "
++
idN
ame
tv
++
>
" occurs more than once on left hand side of type declaration"
>
errNoVariable
::
Ident
->
Message
>
errNoVariable
tv
=
posErr
tv
$
"Type constructor "
++
n
ame
tv
++
>
errNoVariable
tv
=
posErr
tv
$
"Type constructor "
++
idN
ame
tv
++
>
" used in left hand side of type declaration"
>
errWrongArity
::
QualIdent
->
Int
->
Int
->
Message
...
...
@@ -344,6 +344,6 @@ Error messages:
>
arguments
n
=
show
n
++
" arguments"
>
errUnboundVariable
::
Ident
->
Message
>
errUnboundVariable
tv
=
posErr
tv
$
"Unbound type variable "
++
n
ame
tv
>
errUnboundVariable
tv
=
posErr
tv
$
"Unbound type variable "
++
idN
ame
tv
\end{verbatim}
src/Checks/PrecCheck.lhs
View file @
43f6528a
...
...
@@ -491,20 +491,20 @@ Error messages.
>
errUndefinedOperator
::
Ident
->
Message
>
errUndefinedOperator
op
=
posErr
op
$
>
"no definition for "
++
n
ame
op
++
" in this scope"
>
"no definition for "
++
idN
ame
op
++
" in this scope"
>
errDuplicatePrecedence
::
Ident
->
Message
>
errDuplicatePrecedence
op
=
posErr
op
$
>
"More than one fixity declaration for "
++
n
ame
op
>
"More than one fixity declaration for "
++
idN
ame
op
>
errInvalidParse
::
String
->
Ident
->
QualIdent
->
Message
>
errInvalidParse
what
op1
op2
=
posErr
op1
$
>
"Invalid use of "
++
what
++
" "
++
n
ame
op1
>
++
" with "
++
qualName
op2
++
(
showLine
$
p
osition
OfQualIdent
op2
)
>
"Invalid use of "
++
what
++
" "
++
idN
ame
op1
>
++
" with "
++
qualName
op2
++
(
showLine
$
qidP
osition
op2
)
>
errAmbiguousParse
::
String
->
QualIdent
->
QualIdent
->
Message
>
errAmbiguousParse
what
op1
op2
=
qposErr
op1
$
>
"Ambiguous use of "
++
what
++
" "
++
qualName
op1
>
++
" with "
++
qualName
op2
++
(
showLine
$
p
osition
OfQualIdent
op2
)
>
++
" with "
++
qualName
op2
++
(
showLine
$
qidP
osition
op2
)
\end{verbatim}
src/Checks/SyntaxCheck.lhs
View file @
43f6528a
...
...
@@ -92,7 +92,7 @@ renaming literals and underscore to disambiguate them.
>
-- |Identifier for global (top-level) declarations
>
globalScopeId
::
Integer
>
globalScopeId
=
u
nique
Id
(
mkIdent
""
)
>
globalScopeId
=
idU
nique
(
mkIdent
""
)
>
-- |Run the syntax check monad
>
runSC
::
SCM
a
->
SCState
->
(
a
,
[
Message
])
...
...
@@ -296,7 +296,7 @@ Furthermore, it is not allowed to declare a label more than once.
>
qualLookupListCons
::
QualIdent
->
RenameEnv
->
[
RenameInfo
]
>
qualLookupListCons
v
env
>
|
v
==
qualifyWith
preludeMIdent
consId
>
=
qualLookupNestEnv
(
qualify
$
q
ual
idId
v
)
env
>
=
qualLookupNestEnv
(
qualify
$
qidId
ent
v
)
env
>
|
otherwise
>
=
[]
...
...
@@ -316,10 +316,10 @@ local declarations.
>
checkTypeDecl
::
Decl
->
SCM
Decl
>
checkTypeDecl
rec
@
(
TypeDecl
_
r
_
(
RecordType
fs
rty
))
=
do
>
checkRecordExtension
$
p
osition
OfIdent
r
>
checkRecordExtension
$
idP
osition
r
>
when
(
isJust
rty
)
$
internalError
>
"SyntaxCheck.checkTypeDecl: illegal record type"
>
when
(
null
fs
)
$
report
$
errEmptyRecord
$
p
osition
OfIdent
r
>
when
(
null
fs
)
$
report
$
errEmptyRecord
$
idP
osition
r
>
return
rec
>
checkTypeDecl
d
=
return
d
...
...
@@ -435,7 +435,7 @@ top-level.
>
=
checkOpLhs
k
env
(
f
.
InfixPattern
t1
op
)
t2
>
|
otherwise
>
=
Left
(
op''
,
OpLhs
(
f
t1
)
op''
t2
)
>
where
(
m
,
op'
)
=
(
q
ual
idMod
op
,
q
ual
idId
op
)
>
where
(
m
,
op'
)
=
(
qidMod
ule
op
,
qidId
ent
op
)
>
op''
=
renameIdent
op'
k
>
checkOpLhs
_
_
f
t
=
Right
(
f
t
)
...
...
@@ -499,7 +499,7 @@ top-level.
>
checkLhs
p
(
OpLhs
t1
op
t2
)
=
do
>
let
wrongCalls
=
concatMap
(
checkParenConstrTerm
(
Just
$
qualify
op
))
[
t1
,
t2
]
>
unless
(
null
wrongCalls
)
$
report
$
errInfixWithoutParens
>
(
p
osition
OfIdent
op
)
wrongCalls
>
(
idP
osition
op
)
wrongCalls
>
liftM2
(
flip
OpLhs
op
)
(
checkConstrTerm
p
t1
)
(
checkConstrTerm
p
t2
)
>
checkLhs
p
(
ApLhs
lhs
ts
)
=
>
liftM2
ApLhs
(
checkLhs
p
lhs
)
(
mapM
(
checkConstrTerm
p
)
ts
)
...
...
@@ -648,7 +648,7 @@ checkParen
>
if
isNothing
t
>
then
do
>
when
(
not
$
null
missings
)
$
report
$
errMissingLabel
>
(
p
osition
OfIdent
l
)
(
head
missings
)
r
"record pattern"
>
(
idP
osition
l
)
(
head
missings
)
r
"record pattern"
>
flip
RecordPattern
t
`
liftM
`
mapM
(
checkFieldPatt
r
)
fs
>
else
if
t
==
Just
(
VariablePattern
anonId
)
>
then
liftM2
RecordPattern
...
...
@@ -671,7 +671,7 @@ checkParen
>
[]
->
report
$
errUndefinedLabel
l
>
[
_
]
->
report
$
errNotALabel
l
>
_
->
report
$
errDuplicateDefinition
l
>
Field
p
l
`
liftM
`
checkConstrTerm
(
p
osition
OfIdent
l
)
t
>
Field
p
l
`
liftM
`
checkConstrTerm
(
idP
osition
l
)
t
>
-- Note: process decls first
>
checkRhs
::
Rhs
->
SCM
Rhs
...
...
@@ -730,7 +730,7 @@ checkParen
>
[
RecordLabel
r
ls
]
->
do
>
unless
(
null
dups
)
$
report
$
errDuplicateLabel
$
head
dups
>
unless
(
null
missings
)
$
report
$
errMissingLabel
>
(
p
osition
OfIdent
l
)
(
head
missings
)
r
"record construction"
>
(
idP
osition
l
)
(
head
missings
)
r
"record construction"
>
RecordConstr
`
liftM
`
mapM
(
checkFieldExpr
r
)
fs
>
where
ls'
=
map
fieldLabel
fs
>
dups
=
maybeToList
(
findDouble
ls'
)
...
...
@@ -757,7 +757,7 @@ checkParen
>
[
RecordLabel
r
_
]
->
do
>
unless
(
null
dups
)
$
report
$
errDuplicateLabel
$
head
dups
>
liftM2
RecordUpdate
(
mapM
(
checkFieldExpr
r
)
fs
)
>
(
checkExpr
(
p
osition
OfIdent
l
)
e
)
>
(
checkExpr
(
idP
osition
l
)
e
)
>
where
dups
=
maybeToList
$
findDouble
$
map
fieldLabel
fs
>
[]
->
report
(
errUndefinedLabel
l
)
>>
return
rec
>
[
_
]
->
report
(
errNotALabel
l
)
>>
return
rec
...
...
@@ -766,7 +766,7 @@ checkParen
>
checkVariable
::
QualIdent
->
SCM
Expression
>
checkVariable
v
>
|
unqualify
v
==
anonId
=
do
>
checkAnonFreeVarsExtension
$
p
osition
OfQualIdent
v
>
checkAnonFreeVarsExtension
$
qidP
osition
v
>
return
$
Variable
v
>
|
otherwise
=
do
>
env
<-
getRenameEnv
...
...
@@ -839,7 +839,7 @@ checkParen
>
[]
->
report
$
errUndefinedLabel
l
>
[
_
]
->
report
$
errNotALabel
l
>
_
->
report
$
errDuplicateDefinition
l
>
Field
p
l
`
liftM
`
checkExpr
(
p
osition
OfIdent
l
)
e
>
Field
p
l
`
liftM
`
checkExpr
(
idP
osition
l
)
e
\end{verbatim}
Auxiliary definitions.
...
...
@@ -986,7 +986,7 @@ Error messages.
>
errUndefinedData
c
=
qposErr
c
$
"Undefined data constructor "
++
qualName
c
>
errUndefinedLabel
::
Ident
->
Message
>
errUndefinedLabel
l
=
posErr
l
$
"Undefined record label `"
++
n
ame
l
++
"`"
>
errUndefinedLabel
l
=
posErr
l
$
"Undefined record label `"
++
idN
ame
l
++
"`"
>
errAmbiguousIdent
::
[
RenameInfo
]
->
QualIdent
->
Message
>
errAmbiguousIdent
rs
|
any
isConstr
rs
=
errAmbiguousData
...
...
@@ -1000,67 +1000,67 @@ Error messages.
>
errDuplicateDefinition
::
Ident
->
Message
>
errDuplicateDefinition
v
=
posErr
v
$
>
"More than one definition for `"
++
n
ame
v
++
"`"
>
"More than one definition for `"
++
idN
ame
v
++
"`"
>
errDuplicateVariable
::
Ident
->
Message
>
errDuplicateVariable
v
=
posErr
v
$
>
n
ame
v
++
" occurs more than once in pattern"
>
idN
ame
v
++
" occurs more than once in pattern"
>
errMultipleDataConstructor
::
[
Ident
]
->
Message
>
errMultipleDataConstructor
[]
=
internalError
>
"SyntaxCheck.errMultipleDataDeclaration: empty list"
>
errMultipleDataConstructor
(
i
:
is
)
=
posErr
i
$
>
"Multiple definitions for data constructor `"
++
n
ame
i
++
"` at:
\n
"
>
"Multiple definitions for data constructor `"
++
idN
ame
i
++
"` at:
\n
"
>
++
unlines
(
map
showPos
(
i
:
is
))
>
where
showPos
=
(
" "
++
)
.
showLine
.
p
osition
OfIdent
>
where
showPos
=
(
" "
++
)
.
showLine
.
idP
osition
>
errDuplicateTypeSig
::
Ident
->
Message
>
errDuplicateTypeSig
v
=
posErr
v
$
>
"More than one type signature for `"
++
n
ame
v
++
"`"
>
"More than one type signature for `"
++
idN
ame
v
++
"`"
>
errDuplicateEvalAnnot
::
Ident
->
Message
>
errDuplicateEvalAnnot
v
=
posErr
v
$
>
"More than one eval annotation for `"
++
n
ame
v
++
"`"
>
"More than one eval annotation for `"
++
idN
ame
v
++
"`"
>
errDuplicateLabel
::
Ident
->
Message
>
errDuplicateLabel
l
=
posErr
l
$
>
"Multiple occurrence of record label `"
++
n
ame
l
++
"`"
>
"Multiple occurrence of record label `"
++
idN
ame
l
++
"`"
>
errMissingLabel
::
Position
->
Ident
->
QualIdent
->
String
->
Message
>
errMissingLabel
p
l
r
what
=
toMessage
p
$
>
"Missing label `"
++
n
ame
l
>
++
"` in the "
++
what
++
" of `"
++
n
ame
(
unqualify
r
)
++
"`"
>
"Missing label `"
++
idN
ame
l
>
++
"` in the "
++
what
++
" of `"
++
idN
ame
(
unqualify
r
)
++
"`"
>
errIllegalLabel
::
Ident
->
QualIdent
->
Message
>
errIllegalLabel
l
r
=
posErr
l
$
>
"Label `"
++
n
ame
l
++
"` is not defined in record `"
>
++
n
ame
(
unqualify
r
)
++
"`"
>
"Label `"
++
idN
ame
l
++
"` is not defined in record `"
>
++
idN
ame
(
unqualify
r
)
++
"`"
>
errIllegalRecordId
::
Ident
->
Message
>
errIllegalRecordId
r
=
posErr
r
$
"Record identifier `"
++
n
ame
r
>
errIllegalRecordId
r
=
posErr
r
$
"Record identifier `"
++
idN
ame
r
>
++
"` already assigned to a data constructor"
>
errNonVariable
::
String
->
Ident
->
Message
>
errNonVariable
what
c
=
posErr
c
$
>
"Data constructor `"
++
n
ame
c
++
"` in left hand side of "
++
what
>
"Data constructor `"
++
idN
ame
c
++
"` in left hand side of "
++
what
>
errNoBody
::
Ident
->
Message
>
errNoBody
v
=
posErr
v
$
"No body for `"
++
n
ame
v
++
"`"
>
errNoBody
v
=
posErr
v
$
"No body for `"
++
idN
ame
v
++
"`"
>
errNoTypeSig
::
Ident
->
Message
>
errNoTypeSig
f
=
posErr
f
$
>
"No type signature for external function `"
++
n
ame
f
++
"`"
>
"No type signature for external function `"
++
idN
ame
f
++
"`"
>
errToplevelPattern
::
Position
->
Message
>
errToplevelPattern
p
=
toMessage
p
>
"Pattern declaration not allowed at top-level"
>
errNotALabel
::
Ident
->
Message
>
errNotALabel
l
=
posErr
l
$
"`"
++
n
ame
l
++
"` is not a record label"
>
errNotALabel
l
=
posErr
l
$
"`"
++
idN
ame
l
++
"` is not a record label"
>
errDifferentArity
::
Ident
->
Message
>
errDifferentArity
f
=
posErr
f
$
>
"Equations for `"
++
n
ame
f
++
"` have different arities"
>
"Equations for `"
++
idN
ame
f
++
"` have different arities"
>
errWrongArity
::
QualIdent
->
Int
->
Int
->
Message
>
errWrongArity
c
arity'
argc
=
qposErr
c
$
...
...
@@ -1086,7 +1086,7 @@ Error messages.
>
errInfixWithoutParens
p
calls
=
toMessage
p
$
>
"Missing parens in infix patterns:
\n
"
++
unlines
(
map
showCall
calls
)
>
where
showCall
(
q1
,
q2
)
=
>
show
q1
++
" "
++
showLine
(
p
osition
OfQualIdent
q1
)
>
++
"calls "
++
show
q2
++
" "
++
showLine
(
p
osition
OfQualIdent
q2
)
>
show
q1
++
" "
++
showLine
(
qidP
osition
q1
)
>
++
"calls "
++
show
q2
++
" "
++
showLine
(
qidP
osition
q2
)
\end{verbatim}
src/Checks/TypeCheck.lhs
View file @
43f6528a
...
...
@@ -504,12 +504,12 @@ signature the declared type must be too general.
>
Nothing
->
modifyValueEnv
$
rebindFun
m
v
arity
sigma
>
Just
sigTy
->
do
>
sigma'
<-
expandPolyType
sigTy
>
unless
(
eqTyScheme
sigma
sigma'
)
$
report
$
errTypeSigTooGeneral
(
p
osition
OfIdent
v
)
m
what
sigTy
sigma
>
unless
(
eqTyScheme
sigma
sigma'
)
$
report
$
errTypeSigTooGeneral
(
idP
osition
v
)
m
what
sigTy
sigma
>
modifyValueEnv
$
rebindFun
m
v
arity
sigma
>
where
>
what
=
text
(
if
poly
then
"Function:"
else
"Variable:"
)
<+>
ppIdent
v
>
genType
poly'
(
ForAll
n
ty
)
>
|
n
>
0
=
internalError
$
"TypeCheck.genVar: "
++
showLine
(
p
osition
OfIdent
v
)
++
show
v
++
" :: "
++
show
ty
>
|
n
>
0
=
internalError
$
"TypeCheck.genVar: "
++
showLine
(
idP
osition
v
)
++
show
v
++
" :: "
++
show
ty
>
|
poly'
=
gen
lvs
ty
>
|
otherwise
=
monoType
ty
>
eqTyScheme
(
ForAll
_
t1
)
(
ForAll
_
t2
)
=
equTypes
t1
t2
...
...
@@ -723,7 +723,7 @@ because of possibly multiple occurrences of variables.
>
->
Field
ConstrTerm
->
TCM
(
Ident
,
Type
)
>
tcFieldPatt
tcPatt
m
f
@
(
Field
_
l
t
)
=
do
>
tyEnv
<-
getValueEnv
>
let
p
=
p
osition
OfIdent
l
>
let
p
=
idP
osition
l
>
lty
<-
maybe
(
freshTypeVar
> >>= (\lty' ->
> modifyValueEnv
...
...
@@ -775,7 +775,7 @@ because of possibly multiple occurrences of variables.
>
case
qualLookupTypeSig
m
v
sigs
of
>
Just
ty
->
expandPolyType
ty
>>=
inst
>
Nothing
->
getValueEnv
>>=
inst
.
funType
m
v
>
where
v'
=
q
ual
idId
v
>
where
v'
=
qidId
ent
v
>
tcExpr
_
(
Constructor
c
)
=
do
>
m
<-
getModuleIdent
>
getValueEnv
>>=
instExist
.
constrType
m
c
...
...
@@ -847,7 +847,7 @@ because of possibly multiple occurrences of variables.
>
where
opType
op'
>
|
op'
==
minusId
=
freshConstrained
[
intType
,
floatType
]
>
|
op'
==
fminusId
=
return
floatType
>
|
otherwise
=
internalError
$
"TypeCheck.tcExpr unary "
++
n
ame
op'
>
|
otherwise
=
internalError
$
"TypeCheck.tcExpr unary "
++
idN
ame
op'
>
tcExpr
p
e
@
(
Apply
e1
e2
)
=
do
>
ty1
<-
tcExpr
p
e1
>
ty2
<-
tcExpr
p
e2
...
...
@@ -985,7 +985,7 @@ because of possibly multiple occurrences of variables.
>
tcFieldExpr
comb
f
@
(
Field
_
l
e
)
=
do
>
m
<-
getModuleIdent
>
tyEnv
<-
getValueEnv
>
let
p
=
p
osition
OfIdent
l
>
let
p
=
idP
osition
l
>
lty
<-
maybe
(
freshTypeVar
>
>>=
(
\
lty'
->
>
modifyValueEnv
(
bindLabel
l
(
qualifyWith
m
(
mkIdent
"#Rec"
))
...
...
@@ -1320,20 +1320,20 @@ Error functions.
>
errRecursiveTypes
[]
=
internalError
>
"TypeCheck.recursiveTypes: empty list"
>
errRecursiveTypes
[
tc
]
=
posErr
tc
$
>
"Recursive synonym type "
++
n
ame
tc
>
"Recursive synonym type "
++
idN
ame
tc
>
errRecursiveTypes
(
tc
:
tcs
)
=
posErr
tc
$
>
"Recursive synonym types "
++
n
ame
tc
++
types
""
tcs
>
"Recursive synonym types "
++
idN
ame
tc
++
types
""
tcs
>
where
>
types
_
[]
=
""
>
types
comm
[
tc1
]
=
comm
++
" and "
++
n
ame
tc1
>
++
showLine
(
p
osition
OfIdent
tc1
)
>
types
_
(
tc1
:
tcs1
)
=
", "
++
n
ame
tc1
>
++
showLine
(
p
osition
OfIdent
tc1
)
>
types
comm
[
tc1
]
=
comm
++
" and "
++
idN
ame
tc1
>
++
showLine
(
idP
osition
tc1
)
>
types
_
(
tc1
:
tcs1
)
=
", "
++
idN
ame
tc1
>
++
showLine
(
idP
osition
tc1
)
>
++
types
","
tcs1
>
errPolymorphicFreeVar
::
Ident
->
Message
>
errPolymorphicFreeVar
v
=
posErr
v
$
>
"Free variable "
++
n
ame
v
++
" has a polymorphic type"
>
"Free variable "
++
idN
ame
v
++
" has a polymorphic type"
>
errTypeSigTooGeneral
::
Position
->
ModuleIdent
->
Doc
->
TypeExpr
->
TypeScheme
>
->
Message
...
...
src/Checks/WarnCheck.hs
View file @
43f6528a
...
...
@@ -517,7 +517,7 @@ insertConstrTerm fp (VariablePattern ident)
|
fp
=
do
c
<-
isConsId
ident
v
<-
isVarId
ident
unless
c
$
if
n
ame
ident
/=
"_"
&&
v
then
visitId
ident
else
insertVar
ident
unless
c
$
if
idN
ame
ident
/=
"_"
&&
v
then
visitId
ident
else
insertVar
ident
|
otherwise
=
do
c
<-
isConsId
ident
unless
c
$
insertVar
ident
...
...
@@ -744,7 +744,7 @@ typeId ident = qualify (renameIdent ident 1)
-- ---------------------------------------------------------------------------
warnMultiplyImportedModule
::
ModuleIdent
->
Message
warnMultiplyImportedModule
mid
=
toMessage
(
p
osition
OfModuleIdent
mid
)
$
warnMultiplyImportedModule
mid
=
toMessage
(
midP
osition
mid
)
$
"Module
\"
"
++
show
mid
++
"
\"
is imported more than once"
warnMultiplyImportedSymbol
::
ModuleIdent
->
Ident
->
Message
...
...
@@ -783,4 +783,4 @@ overlappingCaseAlt :: Position -> Message
overlappingCaseAlt
p
=
toMessage
p
"Redundant overlapping case alternative"
posWarn
::
Ident
->
String
->
Message
posWarn
i
msg
=
toMessage
(
p
osition
OfIdent
i
)
msg
posWarn
i
msg
=
toMessage
(
idP
osition
i
)
msg
src/CurryBuilder.hs
View file @
43f6528a
...
...
@@ -56,7 +56,7 @@ findCurry opts str = do
Just
fn
->
return
$
Right
fn
where
canBeFile
=
isCurryFilePath
str
canBeModule
=
isModuleName
str
canBeModule
=
is
Valid
ModuleName
str
moduleFile
=
moduleNameToFile
$
fromModuleName
str
paths
=
optImportPaths
opts
fileSearch
=
if
canBeFile
...
...
src/Env/OpPrec.hs
View file @
43f6528a
...
...
@@ -53,7 +53,7 @@ type PEnv = TopEnv PrecInfo
bindP
::
ModuleIdent
->
Ident
->
OpPrec
->
PEnv
->
PEnv
bindP
m
op
p
|
u
nique
Id
op
==
0
=
bindTopEnv
fun
op
info
.
qualBindTopEnv
fun
qop
info
|
idU
nique
op
==
0
=
bindTopEnv
fun
op
info
.
qualBindTopEnv
fun
qop
info
|
otherwise
=
bindTopEnv
fun
op
info
where
qop
=
qualifyWith
m
op
info
=
PrecInfo
qop
p
...
...
src/Env/Value.hs
View file @
43f6528a
...
...
@@ -83,7 +83,7 @@ bindGlobalInfo f m c ty = bindTopEnv fun c v . qualBindTopEnv fun qc v
bindFun
::
ModuleIdent
->
Ident
->
Int
->
TypeScheme
->
ValueEnv
->
ValueEnv
bindFun
m
f
a
ty
|
u
nique
Id
f
==
0
=
bindTopEnv
fun
f
v
.
qualBindTopEnv
fun
qf
v
|
idU
nique
f
==
0
=
bindTopEnv
fun
f
v
.
qualBindTopEnv
fun
qf
v
|
otherwise
=
bindTopEnv
fun
f
v
where
qf
=
qualifyWith
m
f
v
=
Value
qf
a
ty
...
...
@@ -97,7 +97,7 @@ qualBindFun m f a ty = qualBindTopEnv "Env.Value.qualBindFun" qf $
rebindFun
::
ModuleIdent
->
Ident
->
Int
->
TypeScheme
->
ValueEnv
->
ValueEnv
rebindFun
m
f
a
ty
|
u
nique
Id
f
==
0
=
rebindTopEnv
f
v
.
qualRebindTopEnv
qf
v
|
idU
nique
f
==
0
=
rebindTopEnv
f
v
.
qualRebindTopEnv
qf
v
|
otherwise
=
rebindTopEnv
f
v
where
qf
=
qualifyWith
m
f
v
=
Value
qf
a
ty
...
...
@@ -122,7 +122,7 @@ qualLookupCons x tyEnv
|
mmid
==
Just
preludeMIdent
&&
qid
==
consId
=
qualLookupTopEnv
(
qualify
qid
)
tyEnv
|
otherwise
=
[]
where
(
mmid
,
qid
)
=
(
q
ual
idMod
x
,
q
ual
idId
x
)
where
(
mmid
,
qid
)
=
(
qidMod
ule
x
,
qidId
ent
x
)
lookupTuple
::
Ident
->
[
ValueInfo
]
lookupTuple
c
...
...
src/Exports.hs
View file @
43f6528a
...
...
@@ -68,7 +68,7 @@ exportInterface' (Module _ Nothing _ _) _ _ _
infixDecl
::
ModuleIdent
->
PEnv
->
Export
->
[
IDecl
]
->
[
IDecl
]
infixDecl
m
pEnv
(
Export
f
)
ds
=
iInfixDecl
m
pEnv
f
ds
infixDecl
m
pEnv
(
ExportTypeWith
tc
cs
)
ds
=
foldr
(
iInfixDecl
m
pEnv
.
qualifyLike
(
q
ual
idMod
tc
))
ds
cs
foldr
(
iInfixDecl
m
pEnv
.
qualifyLike
(
qidMod
ule
tc
))
ds
cs
where
qualifyLike
=
maybe
qualify
qualifyWith
infixDecl
_
_
_
_
=
internalError
"Exports.infixDecl: no pattern match"
...
...
@@ -144,7 +144,7 @@ funDecl _ _ _ _ = internalError "Exports.funDecl: no pattern match"
-- the interface for module @C@ will import module @A@ but not module @B@.
usedModules
::
[
IDecl
]
->
[
ModuleIdent
]
usedModules
ds
=
nub'
(
catMaybes
(
map
q
ual
idMod
(
foldr
identsDecl
[]
ds
)))
usedModules
ds
=
nub'
(
catMaybes
(
map
qidMod
ule
(
foldr
identsDecl
[]
ds
)))
where
nub'
=
Set
.
toList
.
Set
.
fromList
identsDecl
::
IDecl
->
[
QualIdent
]
->
[
QualIdent
]
...
...
src/Generators/GenAbstractCurry.hs
View file @
43f6528a
...
...
@@ -134,7 +134,7 @@ genTypeDecl env (DataDecl _ n vs cs)
=
(
resetScope
env2
,
CType
(
genQName
True
env2
$
qualifyWith
(
moduleId
env
)
n
)
(
genVisibility
env2
n
)
(
zip
idxs
$
map
n
ame
vs
)
(
zip
idxs
$
map
idN
ame
vs
)
cs'
)
where
(
env1
,
idxs
)
=
mapAccumL
genTVarIndex
env
vs
...
...
@@ -143,7 +143,7 @@ genTypeDecl env (TypeDecl _ n vs ty)
=
(
resetScope
env2
,
CTypeSyn
(
genQName
True
env2
$
qualifyWith
(
moduleId
env
)
n
)
(
genVisibility
env2
n
)
(
zip
idxs
$
map
n
ame
vs
)
(
zip
idxs
$
map
idN
ame
vs
)
ty'
)
where
(
env1
,
idxs
)
=
mapAccumL
genTVarIndex
env
vs
...
...
@@ -172,8 +172,8 @@ genTypeExpr env (ConstructorType q vs)
=
(
env'
,
CTCons
(
genQName
True
env'
q
)
vs'
)
where
(
env'
,
vs'
)
=
mapAccumL
genTypeExpr
env
vs
genTypeExpr
env
(
VariableType
ident
)
=
case
getTVarIndex
env
ident
of
Just
ix
->
(
env
,
CTVar
(
ix
,
n
ame
ident
))
Nothing
->
(
env'
,
CTVar
(
idx
,
n
ame
ident
))
Just
ix
->
(
env
,
CTVar
(
ix
,
idN
ame
ident
))
Nothing
->
(
env'
,
CTVar
(
idx
,
idN
ame
ident
))
where
(
env'
,
idx
)
=
genTVarIndex
env
ident
genTypeExpr
env
(
TupleType
tys
)
=
genTypeExpr
env
$
case
tys
of
[]
->
ConstructorType
qUnitId
[]
...
...
@@ -197,7 +197,7 @@ genTypeExpr env (RecordType fss mr) = case mr of
where
(
ls
,
ts
)
=
unzip
$
concatMap
(
\
(
ls1
,
ty
)
->
map
(
\
l
->
(
l
,
ty
))
ls1
)
fss
(
env1
,
ts'
)
=
mapAccumL
genTypeExpr
env
ts
ls'
=
map
n
ame
ls
ls'
=
map
idN
ame
ls
genOpDecl
::
AbstractEnv
->
Decl
->
[
COpDecl
]
genOpDecl
env
(
InfixDecl
_
fix
prec
ops
)
=
map
genCOp
(
reverse
ops
)
...
...
@@ -259,9 +259,9 @@ genFuncDecl isLocal env (ident, decls)
internalError
"GenAbstractCurry.genFuncDecl.genTypeSig: no pattern match"
genExternal
(
ExternalDecl
_
_
mname
ident'
_
)
=
CExternal
(
fromMaybe
(
n
ame
ident'
)
mname
)
=
CExternal
(
fromMaybe
(
idN
ame
ident'
)
mname
)
genExternal
(
FlatExternalDecl
_
[
ident'
])
=
CExternal
(
n
ame
ident'
)
=
CExternal
(
idN
ame
ident'
)
genExternal
_
=
internalError
$
"GenAbstractCurry.genExternal: "
++
"illegal external declaration occured"
...
...
@@ -375,7 +375,7 @@ genLocalDecls env decls
(
getVarIndex
env'
ident
)
decls'
=
ExtraVariables
pos
(
tail
idents
)
:
decls1
(
env''
,
locals
)
=
genLocals
env'
fdecls
decls'
in
(
env''
,
CLocalVar
(
idx
,
n
ame
ident
)
:
locals
)
in
(
env''
,
CLocalVar
(
idx
,
idN
ame
ident
)
:
locals
)
genLocals
env'
fdecls
((
TypeSig
_
_
_
)
:
decls1
)
=
genLocals
env'
fdecls
decls1
genLocals
_
_
decl
=
internalError
(
"GenAbstractCurry.genLocals: unexpected local declaration:
\n
"
++
show
(
head
decl
))
...
...
@@ -398,7 +398,7 @@ genLocalDecls env decls
genLocalPattern
_
env'
(
VariablePattern
v
)
=
case
getVarIndex
env'
v
of
Nothing
->
internalError
$
"GenAbstractCurry.genLocalPattern: "
++
"cannot find index"
++
" for pattern variable
\"
"
++
show
v
++
"
\"
"
Just
idx
->
(
env'
,
CPVar
(
idx
,
n
ame
v
))
Just
idx
->
(
env'
,
CPVar
(
idx
,
idN
ame
v
))
genLocalPattern
pos
env'
(
ConstructorPattern
qident
args
)
=
let
(
env''
,
args'
)
=
mapAccumL
(
genLocalPattern
pos
)
env'
args
in
(
env''
,
CPComb
(
genQName
False
env'
qident
)
args'
)
...
...
@@ -425,7 +425,7 @@ genLocalDecls env decls
++
" for alias variable
\"
"
++
show
ident
++
"
\"
"
))
(
getVarIndex
env1
ident
)