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
ba21a418
Commit
ba21a418
authored
Aug 10, 2011
by
Björn Peemöller
Browse files
Merge branch 'master' of /home/bjp/public_html/repos/curry-frontend
parents
50d60cf5
9b576eac
Changes
20
Expand all
Show whitespace changes
Inline
Side-by-side
.gitignore
View file @
ba21a418
dist/
*/
.curry
.curry
/
curry-frontend.cabal
View file @
ba21a418
...
...
@@ -41,6 +41,7 @@ Executable cymake
Other-Modules:
Base.Arity
, Base.Eval
, Base.Expr
, Base.Import
, Base.Module
, Base.OpPrec
...
...
src/Base/Expr.hs
0 → 100644
View file @
ba21a418
{- |Free and bound variables
The compiler needs to compute the sets 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
definitions as \emph{M.x} always denotes an entity defined at the
top-level.
-}
module
Base.Expr
(
Expr
(
..
),
QualExpr
(
..
),
QuantExpr
(
..
))
where
import
qualified
Data.Set
as
Set
(
fromList
,
notMember
)
import
Curry.Base.Ident
import
Curry.Syntax
import
qualified
IL
class
Expr
e
where
fv
::
e
->
[
Ident
]
class
QualExpr
e
where
qfv
::
ModuleIdent
->
e
->
[
Ident
]
class
QuantExpr
e
where
bv
::
e
->
[
Ident
]
instance
Expr
e
=>
Expr
[
e
]
where
fv
=
concatMap
fv
instance
QualExpr
e
=>
QualExpr
[
e
]
where
qfv
m
=
concatMap
(
qfv
m
)
instance
QuantExpr
e
=>
QuantExpr
[
e
]
where
bv
=
concatMap
bv
-- The \texttt{Decl} instance of \texttt{QualExpr} returns all free
-- variables on the right hand side, regardless of whether they are bound
-- on the left hand side. This is more convenient as declarations are
-- usually processed in a declaration group where the set of free
-- variables cannot be computed independently for each declaration. Also
-- note that the operator in a unary minus expression is not a free
-- variable. This operator always refers to a global function from the
-- prelude.
instance
QualExpr
Decl
where
qfv
m
(
FunctionDecl
_
_
eqs
)
=
qfv
m
eqs
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
(
ExternalDecl
_
_
_
f
_
)
=
[
f
]
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
)
instance
QuantExpr
Lhs
where
bv
=
bv
.
snd
.
flatLhs
instance
QualExpr
Lhs
where
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
)
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
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
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
(
StmtBind
_
_
e
)
=
qfv
m
e
instance
QualExpr
Alt
where
qfv
m
(
Alt
_
t
rhs
)
=
filterBv
t
(
qfv
m
rhs
)
instance
QuantExpr
a
=>
QuantExpr
(
Field
a
)
where
bv
(
Field
_
_
t
)
=
bv
t
instance
QualExpr
a
=>
QualExpr
(
Field
a
)
where
qfv
m
(
Field
_
_
t
)
=
qfv
m
t
instance
QuantExpr
Statement
where
bv
(
StmtExpr
_
_
)
=
[]
bv
(
StmtBind
_
t
_
)
=
bv
t
bv
(
StmtDecl
ds
)
=
bv
ds
instance
QualExpr
InfixOp
where
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
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
)
=
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
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
)
filterBv
::
QuantExpr
e
=>
e
->
[
Ident
]
->
[
Ident
]
filterBv
e
=
filter
(`
Set
.
notMember
`
Set
.
fromList
(
bv
e
))
-- Since multiple variable occurrences are allowed in function patterns,
-- it is necessary to compute the list of bound variables in a different way:
-- Each variable occuring in the function pattern will be unique in the result
-- list.
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
(
InfixFuncPattern
t1
_
t2
)
=
foldl
bvfp
bvs
[
t1
,
t2
]
bvfp
bvs
(
RecordPattern
fs
r
)
=
foldl
bvfp
(
maybe
bvs
(
bvfp
bvs
)
r
)
(
map
fieldTerm
fs
)
-- intermediate language
instance
Expr
IL
.
Expression
where
fv
(
IL
.
Variable
v
)
=
[
v
]
fv
(
IL
.
Apply
e1
e2
)
=
fv
e1
++
fv
e2
fv
(
IL
.
Case
_
_
e
alts
)
=
fv
e
++
fv
alts
fv
(
IL
.
Or
e1
e2
)
=
fv
e1
++
fv
e2
fv
(
IL
.
Exist
v
e
)
=
filter
(
/=
v
)
(
fv
e
)
fv
(
IL
.
Let
(
IL
.
Binding
v
e1
)
e2
)
=
fv
e1
++
filter
(
/=
v
)
(
fv
e2
)
fv
(
IL
.
Letrec
bds
e
)
=
filter
(`
notElem
`
vs
)
(
fv
es
++
fv
e
)
where
(
vs
,
es
)
=
unzip
[(
v
,
e'
)
|
IL
.
Binding
v
e'
<-
bds
]
fv
_
=
[]
instance
Expr
IL
.
Alt
where
fv
(
IL
.
Alt
(
IL
.
ConstructorPattern
_
vs
)
e
)
=
filter
(`
notElem
`
vs
)
(
fv
e
)
fv
(
IL
.
Alt
(
IL
.
VariablePattern
v
)
e
)
=
filter
(
v
/=
)
(
fv
e
)
fv
(
IL
.
Alt
_
e
)
=
fv
e
src/Base/Types.lhs
View file @
ba21a418
...
...
@@ -19,10 +19,10 @@ order of type variables in the left hand side of a type declaration.
>
import
Data.List
(
nub
)
>
import
qualified
Data.Map
as
Map
(
Map
,
fromList
,
lookup
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Ident
>
import
qualified
Curry.Syntax
as
CS
>
import
Base.Expr
>
import
Messages
(
internalError
)
>
import
Types
...
...
src/Check/PrecCheck.lhs
View file @
ba21a418
...
...
@@ -19,11 +19,11 @@ of the operators involved.
>
import
Data.List
(
partition
,
mapAccumL
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Base.Expr
>
import
Base.OpPrec
(
PEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
qualLookupP
)
>
import
Messages
(
errorAt'
)
>
import
Utils
(
findDouble
)
...
...
src/Check/SyntaxCheck.lhs
View file @
ba21a418
...
...
@@ -26,12 +26,12 @@ merged into a single definition.
>
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
>
import
Control.Monad.State
as
S
(
State
,
evalState
,
get
,
liftM
,
modify
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Base.Arity
(
ArityEnv
,
ArityInfo
(
..
),
lookupArity
,
qualLookupArity
)
>
import
Base.Expr
>
import
Base.Import
(
ImportEnv
,
lookupAlias
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
))
...
...
src/Check/TypeCheck.lhs
View file @
ba21a418
...
...
@@ -30,12 +30,12 @@ type annotation is present.
>
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
>
import
Text.PrettyPrint.HughesPJ
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Curry.Syntax.Pretty
>
import
Base.Expr
>
import
Base.Types
(
fromQualType
,
toType
,
toTypes
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
bindTypeInfo
,
qualLookupTC
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
bindFun
,
rebindFun
...
...
src/Check/WarnCheck.hs
View file @
ba21a418
...
...
@@ -28,7 +28,7 @@ import Env.ScopeEnv (ScopeEnv)
type
CheckState
=
State
CState
data
CState
=
CState
{
messages
::
[
WarnMsg
]
{
messages
::
[
Message
]
,
scope
::
ScopeEnv
QualIdent
IdInfo
,
values
::
ValueEnv
,
moduleId
::
ModuleIdent
...
...
@@ -38,7 +38,7 @@ emptyState :: CState
emptyState
=
CState
[]
ScopeEnv
.
new
emptyTopEnv
(
mkMIdent
[]
)
-- |Run a 'CheckState' action and return the list of messages
run
::
CheckState
a
->
[
WarnMsg
]
run
::
CheckState
a
->
[
Message
]
run
f
=
reverse
(
messages
(
execState
f
emptyState
))
-- Find potentially incorrect code in a Curry program and generate
...
...
@@ -48,7 +48,7 @@ run f = reverse (messages (execState f emptyState))
-- - idle case alternatives
-- - overlapping case alternatives
-- - function rules which are not together
warnCheck
::
ModuleIdent
->
ValueEnv
->
[
Decl
]
->
[
Decl
]
->
[
WarnMsg
]
warnCheck
::
ModuleIdent
->
ValueEnv
->
[
Decl
]
->
[
Decl
]
->
[
Message
]
warnCheck
mid
vals
imports
decls
=
run
$
do
addImportedValues
vals
addModuleId
mid
...
...
@@ -596,12 +596,12 @@ modifyScope f state = state{ scope = f (scope state) }
genWarning
::
Position
->
String
->
CheckState
()
genWarning
pos
msg
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
where
warnMsg
=
WarnMsg
(
Just
pos
)
msg
where
warnMsg
=
Message
(
Just
pos
)
msg
genWarning'
::
(
Position
,
String
)
->
CheckState
()
genWarning'
(
pos
,
msg
)
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
where
warnMsg
=
WarnMsg
(
Just
pos
)
msg
where
warnMsg
=
Message
(
Just
pos
)
msg
--
insertVar
::
Ident
->
CheckState
()
...
...
src/CurryToIL.lhs
View file @
ba21a418
...
...
@@ -25,13 +25,13 @@ data structures, we can use only a qualified import for the
>
import
qualified
Data.Set
as
Set
(
delete
,
fromList
,
toList
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
qualified
IL
as
IL
>
import
Curry.Syntax
>
import
Base.Eval
(
EvalEnv
)
>
import
Base.Expr
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.Types
(
toQualTypes
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
...
...
src/Frontend.hs
View file @
ba21a418
...
...
@@ -66,7 +66,7 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax
::
(
Options
->
ModuleEnv
->
CS
.
Module
->
IO
(
a
,
b
,
c
,
CS
.
Module
,
d
,
[
WarnMsg
]))
(
Options
->
ModuleEnv
->
CS
.
Module
->
IO
(
a
,
b
,
c
,
CS
.
Module
,
d
,
[
Message
]))
->
[
FilePath
]
->
MsgMonad
CS
.
Module
->
IO
(
MsgMonad
CS
.
Module
)
genFullCurrySyntax
check
paths
m
=
runMsgIO
m
$
\
mod1
->
do
errs
<-
makeInterfaces
paths
mod1
...
...
src/Gen/GenFlatCurry.hs
View file @
ba21a418
...
...
@@ -47,7 +47,7 @@ trace' _ x = x
-- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatCurry
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
prog'
,
messages
)
where
(
prog
,
messages
)
...
...
@@ -57,7 +57,7 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
...
...
@@ -120,7 +120,7 @@ data FlatEnv = FlatEnv
,
varIndexE
::
Int
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
tvarIndexE
::
Int
,
messagesE
::
[
WarnMsg
]
,
messagesE
::
[
Message
]
,
genInterfaceE
::
Bool
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
...
...
@@ -132,7 +132,7 @@ data IdentExport = NotConstr -- function, type-constructor
-- Runs a 'FlatState' action and returns the result
run
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
Bool
->
FlatState
a
->
(
a
,
[
WarnMsg
])
->
Bool
->
FlatState
a
->
(
a
,
[
Message
])
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
genIntf
f
=
(
result
,
messagesE
env
)
where
...
...
@@ -1084,7 +1084,7 @@ clearVarIndices = modify (\env -> env { varIndexE = 0,
genWarning
::
String
->
FlatState
()
genWarning
msg
=
modify
(
\
env
->
env
{
messagesE
=
warnMsg
:
(
messagesE
env
)
})
where
warnMsg
=
WarnMsg
Nothing
msg
where
warnMsg
=
Message
Nothing
msg
--
genInterface
::
FlatState
Bool
...
...
src/Html/SyntaxColoring.hs
View file @
ba21a418
...
...
@@ -43,7 +43,7 @@ data Code = Keyword String
|
CharCode
String
|
Symbol
String
|
Identifier
IdentifierKind
QualIdent
|
CodeWarning
[
WarnMsg
]
Code
|
CodeWarning
[
Message
]
Code
|
NotParsed
String
deriving
Show
...
...
@@ -114,10 +114,10 @@ getQualIdent _ = Nothing
-- DEBUGGING----------- wird bald nicht mehr gebraucht
setMessagePosition
::
WarnMsg
->
WarnMsg
setMessagePosition
m
@
(
WarnMsg
(
Just
p
)
_
)
=
trace''
(
"pos:"
++
show
p
++
":"
++
show
m
)
m
setMessagePosition
(
WarnMsg
_
m
)
=
let
mes
@
(
WarnMsg
pos
_
)
=
(
WarnMsg
(
getPositionFromString
m
)
m
)
in
setMessagePosition
::
Message
->
Message
setMessagePosition
m
@
(
Message
(
Just
p
)
_
)
=
trace''
(
"pos:"
++
show
p
++
":"
++
show
m
)
m
setMessagePosition
(
Message
_
m
)
=
let
mes
@
(
Message
pos
_
)
=
(
Message
(
getPositionFromString
m
)
m
)
in
trace''
(
"pos:"
++
show
pos
++
":"
++
show
mes
)
mes
getPositionFromString
::
String
->
Maybe
Position
...
...
@@ -144,28 +144,28 @@ flatCode code = code
-- ----------Message---------------------------------------
getMessages
::
MsgMonad
a
->
[
WarnMsg
]
getMessages
::
MsgMonad
a
->
[
Message
]
getMessages
=
snd
.
runMsg
--(Result mess _) = mess
-- getMessages (Failure mess) = mess
lessMessage
::
WarnMsg
->
WarnMsg
->
Bool
lessMessage
(
WarnMsg
mPos1
_
)
(
WarnMsg
mPos2
_
)
=
mPos1
<
mPos2
lessMessage
::
Message
->
Message
->
Bool
lessMessage
(
Message
mPos1
_
)
(
Message
mPos2
_
)
=
mPos1
<
mPos2
nubMessages
::
[
WarnMsg
]
->
[
WarnMsg
]
nubMessages
::
[
Message
]
->
[
Message
]
nubMessages
=
nubBy
eqMessage
eqMessage
::
WarnMsg
->
WarnMsg
->
Bool
eqMessage
(
WarnMsg
p1
s1
)
(
WarnMsg
p2
s2
)
=
(
p1
==
p2
)
&&
(
s1
==
s2
)
eqMessage
::
Message
->
Message
->
Bool
eqMessage
(
Message
p1
s1
)
(
Message
p2
s2
)
=
(
p1
==
p2
)
&&
(
s1
==
s2
)
prepareMessages
::
[
WarnMsg
]
->
[
WarnMsg
]
prepareMessages
::
[
Message
]
->
[
Message
]
prepareMessages
=
qsort
lessMessage
.
map
setMessagePosition
.
nubMessages
buildMessagesIntoPlainText
::
[
WarnMsg
]
->
String
->
Program
buildMessagesIntoPlainText
::
[
Message
]
->
String
->
Program
buildMessagesIntoPlainText
messages
text
=
buildMessagesIntoPlainText'
messages
(
lines
text
)
[]
1
where
buildMessagesIntoPlainText'
::
[
WarnMsg
]
->
[
String
]
->
[
String
]
->
Int
->
Program
buildMessagesIntoPlainText'
::
[
Message
]
->
[
String
]
->
[
String
]
->
Int
->
Program
buildMessagesIntoPlainText'
_
[]
[]
_
=
[]
buildMessagesIntoPlainText'
_
[]
postStrs
ln
=
...
...
@@ -182,7 +182,7 @@ buildMessagesIntoPlainText messages text =
(
ln
,
1
,
NewLine
)
:
buildMessagesIntoPlainText'
post
preStrs
[]
(
ln
+
1
)
where
isLeq
(
WarnMsg
(
Just
p
)
_
)
=
line
p
<=
ln
isLeq
(
Message
(
Just
p
)
_
)
=
line
p
<=
ln
isLeq
_
=
True
--- @param parse-Modules [typingParse,fullParse,parse]
...
...
@@ -272,15 +272,15 @@ addModuleIdent _ c = c
-- ----------------------------------------
mergeMessages'
::
[
WarnMsg
]
->
[(
Position
,
Token
)]
->
[([
WarnMsg
],
Position
,
Token
)]
mergeMessages'
::
[
Message
]
->
[(
Position
,
Token
)]
->
[([
Message
],
Position
,
Token
)]
mergeMessages'
_
[]
=
[]
mergeMessages'
[]
((
p
,
t
)
:
ps
)
=
(
[]
,
p
,
t
)
:
mergeMessages'
[]
ps
mergeMessages'
mss
@
(
m
@
(
WarnMsg
mPos
x
)
:
ms
)
((
p
,
t
)
:
ps
)
mergeMessages'
mss
@
(
m
@
(
Message
mPos
x
)
:
ms
)
((
p
,
t
)
:
ps
)
|
mPos
<=
Just
p
=
trace'
(
show
mPos
++
" <= "
++
show
(
Just
p
)
++
" Message: "
++
x
)
([
m
],
p
,
t
)
:
mergeMessages'
ms
ps
|
otherwise
=
(
[]
,
p
,
t
)
:
mergeMessages'
mss
ps
tokenNcodes2codes
::
[(
ModuleIdent
,
ModuleIdent
)]
->
Int
->
Int
->
[([
WarnMsg
],
Position
,
Token
)]
->
[
Code
]
->
[(
Int
,
Int
,
Code
)]
tokenNcodes2codes
::
[(
ModuleIdent
,
ModuleIdent
)]
->
Int
->
Int
->
[([
Message
],
Position
,
Token
)]
->
[
Code
]
->
[(
Int
,
Int
,
Code
)]
tokenNcodes2codes
_
_
_
[]
_
=
[]
tokenNcodes2codes
nameList
currLine
currCol
toks
@
((
messages
,
Position
{
line
=
row
,
column
=
col
},
token
)
:
ts
)
codes
|
currLine
<
row
=
...
...
src/IL/Type.lhs
View file @
ba21a418
...
...
@@ -48,7 +48,6 @@ an unlimited range of integer constants in Curry programs.
>
import
Data.Generics
>
import
Curry.Base.Expr
>
import
Curry.Base.Ident
>
import
Curry.Base.Position
(
SrcRef
(
..
))
...
...
@@ -59,22 +58,22 @@ an unlimited range of integer constants in Curry programs.
>
|
NewtypeDecl
QualIdent
Int
(
ConstrDecl
Type
)
>
|
FunctionDecl
QualIdent
[
Ident
]
Type
Expression
>
|
ExternalDecl
QualIdent
CallConv
String
Type
>
deriving
(
Eq
,
Show
)
>
deriving
(
Eq
,
Show
)
>
data
ConstrDecl
a
=
ConstrDecl
QualIdent
a
deriving
(
Eq
,
Show
)
>
data
CallConv
=
Primitive
|
CCall
deriving
(
Eq
,
Show
)
>
data
ConstrDecl
a
=
ConstrDecl
QualIdent
a
deriving
(
Eq
,
Show
)
>
data
CallConv
=
Primitive
|
CCall
deriving
(
Eq
,
Show
)
>
data
Type
>
=
TypeConstructor
QualIdent
[
Type
]
>
|
TypeVariable
Int
>
|
TypeArrow
Type
Type
>
deriving
(
Eq
,
Show
,
Typeable
,
Data
)
>
deriving
(
Eq
,
Show
,
Typeable
,
Data
)
>
data
Literal
>
=
Char
SrcRef
Char
>
|
Int
SrcRef
Integer
>
|
Float
SrcRef
Double
>
deriving
(
Eq
,
Show
)
>
deriving
(
Eq
,
Show
)
>
data
ConstrTerm
>
-- |literal patterns
...
...
@@ -112,8 +111,6 @@ an unlimited range of integer constants in Curry programs.
>
data
Alt
=
Alt
ConstrTerm
Expression
deriving
(
Eq
,
Show
)
>
data
Binding
=
Binding
Ident
Expression
deriving
(
Eq
,
Show
)
\end{verbatim}
>
instance
SrcRefOf
ConstrTerm
where
>
srcRefOf
(
LiteralPattern
l
)
=
srcRefOf
l
>
srcRefOf
(
ConstructorPattern
i
_
)
=
srcRefOf
i
...
...
@@ -124,18 +121,4 @@ an unlimited range of integer constants in Curry programs.
>
srcRefOf
(
Int
s
_
)
=
s
>
srcRefOf
(
Float
s
_
)
=
s
>
instance
Expr
Expression
where
>
fv
(
Variable
v
)
=
[
v
]
>
fv
(
Apply
e1
e2
)
=
fv
e1
++
fv
e2
>
fv
(
Case
_
_
e
alts
)
=
fv
e
++
fv
alts
>
fv
(
Or
e1
e2
)
=
fv
e1
++
fv
e2
>
fv
(
Exist
v
e
)
=
filter
(
/=
v
)
(
fv
e
)
>
fv
(
Let
(
Binding
v
e1
)
e2
)
=
fv
e1
++
filter
(
/=
v
)
(
fv
e2
)
>
fv
(
Letrec
bds
e
)
=
filter
(`
notElem
`
vs
)
(
fv
es
++
fv
e
)
>
where
(
vs
,
es
)
=
unzip
[(
v
,
e'
)
|
Binding
v
e'
<-
bds
]
>
fv
_
=
[]
>
instance
Expr
Alt
where
>
fv
(
Alt
(
ConstructorPattern
_
vs
)
e
)
=
filter
(`
notElem
`
vs
)
(
fv
e
)
>
fv
(
Alt
(
VariablePattern
v
)
e
)
=
filter
(
v
/=
)
(
fv
e
)
>
fv
(
Alt
_
e
)
=
fv
e
\ No newline at end of file
\end{verbatim}
src/Modules.lhs
View file @
ba21a418
...
...
@@ -217,7 +217,7 @@ generated FlatCurry terms (type \texttt{Prog}).
>
mintf
<-
readFlatInterface
fn
>
let
intf
=
fromMaybe
(
errorAt
(
first
fn
)
(
interfaceNotFound
m
))
mintf
>
(
Prog
modul
_
_
_
_
)
=
intf
>
m'
=
mkMIdent
[
modul
]
>
m'
=
fromModuleName
modul
>
unless
(
m'
==
m
)
(
errorAt
(
first
fn
)
(
wrongInterface
m
m'
))
>
mEnv'
<-
loadFlatInterfaces
paths
ctxt
mEnv
intf
>
return
$
bindFlatInterface
intf
mEnv'
...
...
@@ -225,9 +225,9 @@ generated FlatCurry terms (type \texttt{Prog}).
>
loadFlatInterfaces
::
[
FilePath
]
->
[
ModuleIdent
]
->
ModuleEnv
->
Prog
>
->
IO
ModuleEnv
>
loadFlatInterfaces
paths
ctxt
mEnv
(
Prog
m
is
_
_
_
)
=
>
foldM
(
loadInterface
paths
(
(
mkMIdent
[
m
])
:
ctxt
))
>
foldM
(
loadInterface
paths
(
fromModuleName
m
:
ctxt
))
>
mEnv
>
(
map
(
\
i
->
(
p
,
mkMIdent
[
i
]
))
is
)
>
(
map
(
\
i
->
(
p
,
fromModuleName
i
))
is
)
>
where
p
=
first
m
Interface files are updated by the Curry builder when necessary.
...
...
@@ -235,7 +235,7 @@ Interface files are updated by the Curry builder when necessary.
>
-- |
>
simpleCheckModule
::
Options
->
ModuleEnv
->
Module
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
WarnMsg
])
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
Message
])
>
simpleCheckModule
opts
mEnv
(
Module
m
es
ds
)
=
do
>
showWarnings
opts
warnMsgs
>
return
(
tyEnv''
,
tcEnv
,
aEnv''
,
modul
,
intf
,
warnMsgs
)
...
...
@@ -259,7 +259,7 @@ Interface files are updated by the Curry builder when necessary.
>
intf
=
exportInterface
modul
pEnv'
tcEnv''
tyEnv''
>
checkModule
::
Options
->
ModuleEnv
->
Module
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
WarnMsg
])
>
->
IO
(
ValueEnv
,
TCEnv
,
ArityEnv
,
Module
,
Interface
,
[
Message
])
>
checkModule
opts
mEnv
(
Module
m
es
ds
)
=
do