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
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
ba21a418
dist/
dist/
*/
.curry
.curry
/
curry-frontend.cabal
View file @
ba21a418
...
@@ -41,6 +41,7 @@ Executable cymake
...
@@ -41,6 +41,7 @@ Executable cymake
Other-Modules:
Other-Modules:
Base.Arity
Base.Arity
, Base.Eval
, Base.Eval
, Base.Expr
, Base.Import
, Base.Import
, Base.Module
, Base.Module
, Base.OpPrec
, 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.
...
@@ -19,10 +19,10 @@ order of type variables in the left hand side of a type declaration.
>
import
Data.List
(
nub
)
>
import
Data.List
(
nub
)
>
import
qualified
Data.Map
as
Map
(
Map
,
fromList
,
lookup
)
>
import
qualified
Data.Map
as
Map
(
Map
,
fromList
,
lookup
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Ident
>
import
Curry.Base.Ident
>
import
qualified
Curry.Syntax
as
CS
>
import
qualified
Curry.Syntax
as
CS
>
import
Base.Expr
>
import
Messages
(
internalError
)
>
import
Messages
(
internalError
)
>
import
Types
>
import
Types
...
...
src/Check/PrecCheck.lhs
View file @
ba21a418
...
@@ -19,11 +19,11 @@ of the operators involved.
...
@@ -19,11 +19,11 @@ of the operators involved.
>
import
Data.List
(
partition
,
mapAccumL
)
>
import
Data.List
(
partition
,
mapAccumL
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Curry.Syntax
>
import
Base.Expr
>
import
Base.OpPrec
(
PEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
qualLookupP
)
>
import
Base.OpPrec
(
PEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
qualLookupP
)
>
import
Messages
(
errorAt'
)
>
import
Messages
(
errorAt'
)
>
import
Utils
(
findDouble
)
>
import
Utils
(
findDouble
)
...
...
src/Check/SyntaxCheck.lhs
View file @
ba21a418
...
@@ -26,12 +26,12 @@ merged into a single definition.
...
@@ -26,12 +26,12 @@ merged into a single definition.
>
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
>
import
qualified
Data.Map
as
Map
(
empty
,
insert
,
lookup
)
>
import
Control.Monad.State
as
S
(
State
,
evalState
,
get
,
liftM
,
modify
)
>
import
Control.Monad.State
as
S
(
State
,
evalState
,
get
,
liftM
,
modify
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Curry.Syntax
>
import
Base.Arity
(
ArityEnv
,
ArityInfo
(
..
),
lookupArity
,
qualLookupArity
)
>
import
Base.Arity
(
ArityEnv
,
ArityInfo
(
..
),
lookupArity
,
qualLookupArity
)
>
import
Base.Expr
>
import
Base.Import
(
ImportEnv
,
lookupAlias
)
>
import
Base.Import
(
ImportEnv
,
lookupAlias
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
))
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
))
...
...
src/Check/TypeCheck.lhs
View file @
ba21a418
...
@@ -30,12 +30,12 @@ type annotation is present.
...
@@ -30,12 +30,12 @@ type annotation is present.
>
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
>
import
qualified
Data.Set
as
Set
(
Set
,
fromList
,
member
,
notMember
,
unions
)
>
import
Text.PrettyPrint.HughesPJ
>
import
Text.PrettyPrint.HughesPJ
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Base.Ident
>
import
Curry.Syntax
>
import
Curry.Syntax
>
import
Curry.Syntax.Pretty
>
import
Curry.Syntax.Pretty
>
import
Base.Expr
>
import
Base.Types
(
fromQualType
,
toType
,
toTypes
)
>
import
Base.Types
(
fromQualType
,
toType
,
toTypes
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
bindTypeInfo
,
qualLookupTC
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
bindTypeInfo
,
qualLookupTC
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
bindFun
,
rebindFun
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
bindFun
,
rebindFun
...
...
src/Check/WarnCheck.hs
View file @
ba21a418
...
@@ -28,7 +28,7 @@ import Env.ScopeEnv (ScopeEnv)
...
@@ -28,7 +28,7 @@ import Env.ScopeEnv (ScopeEnv)
type
CheckState
=
State
CState
type
CheckState
=
State
CState
data
CState
=
CState
data
CState
=
CState
{
messages
::
[
WarnMsg
]
{
messages
::
[
Message
]
,
scope
::
ScopeEnv
QualIdent
IdInfo
,
scope
::
ScopeEnv
QualIdent
IdInfo
,
values
::
ValueEnv
,
values
::
ValueEnv
,
moduleId
::
ModuleIdent
,
moduleId
::
ModuleIdent
...
@@ -38,7 +38,7 @@ emptyState :: CState
...
@@ -38,7 +38,7 @@ emptyState :: CState
emptyState
=
CState
[]
ScopeEnv
.
new
emptyTopEnv
(
mkMIdent
[]
)
emptyState
=
CState
[]
ScopeEnv
.
new
emptyTopEnv
(
mkMIdent
[]
)
-- |Run a 'CheckState' action and return the list of messages
-- |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
))
run
f
=
reverse
(
messages
(
execState
f
emptyState
))
-- Find potentially incorrect code in a Curry program and generate
-- Find potentially incorrect code in a Curry program and generate
...
@@ -48,7 +48,7 @@ run f = reverse (messages (execState f emptyState))
...
@@ -48,7 +48,7 @@ run f = reverse (messages (execState f emptyState))
-- - idle case alternatives
-- - idle case alternatives
-- - overlapping case alternatives
-- - overlapping case alternatives
-- - function rules which are not together
-- - 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
warnCheck
mid
vals
imports
decls
=
run
$
do
addImportedValues
vals
addImportedValues
vals
addModuleId
mid
addModuleId
mid
...
@@ -596,12 +596,12 @@ modifyScope f state = state{ scope = f (scope state) }
...
@@ -596,12 +596,12 @@ modifyScope f state = state{ scope = f (scope state) }
genWarning
::
Position
->
String
->
CheckState
()
genWarning
::
Position
->
String
->
CheckState
()
genWarning
pos
msg
genWarning
pos
msg
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
where
warnMsg
=
WarnMsg
(
Just
pos
)
msg
where
warnMsg
=
Message
(
Just
pos
)
msg
genWarning'
::
(
Position
,
String
)
->
CheckState
()
genWarning'
::
(
Position
,
String
)
->
CheckState
()
genWarning'
(
pos
,
msg
)
genWarning'
(
pos
,
msg
)
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
=
modify
(
\
state
->
state
{
messages
=
warnMsg
:
(
messages
state
)
})
where
warnMsg
=
WarnMsg
(
Just
pos
)
msg
where
warnMsg
=
Message
(
Just
pos
)
msg
--
--
insertVar
::
Ident
->
CheckState
()
insertVar
::
Ident
->
CheckState
()
...
...
src/CurryToIL.lhs
View file @
ba21a418
...
@@ -25,13 +25,13 @@ data structures, we can use only a qualified import for the
...
@@ -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.Set
as
Set
(
delete
,
fromList
,
toList
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
)
>
import
Curry.Base.Expr
>
import
Curry.Base.Position
>
import
Curry.Base.Position
>
import
Curry.Base.Ident
>
import
Curry.Base.Ident
>
import
qualified
IL
as
IL
>
import
qualified
IL
as
IL
>
import
Curry.Syntax
>
import
Curry.Syntax
>
import
Base.Eval
(
EvalEnv
)
>
import
Base.Eval
(
EvalEnv
)
>
import
Base.Expr
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
qualLookupTC
)
>
import
Base.Types
(
toQualTypes
)
>
import
Base.Types
(
toQualTypes
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
>
import
Base.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
...
...
src/Frontend.hs
View file @
ba21a418
...
@@ -66,7 +66,7 @@ genCurrySyntax fn mod1
...
@@ -66,7 +66,7 @@ genCurrySyntax fn mod1
--
--
genFullCurrySyntax
::
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
)
->
[
FilePath
]
->
MsgMonad
CS
.
Module
->
IO
(
MsgMonad
CS
.
Module
)
genFullCurrySyntax
check
paths
m
=
runMsgIO
m
$
\
mod1
->
do
genFullCurrySyntax
check
paths
m
=
runMsgIO
m
$
\
mod1
->
do
errs
<-
makeInterfaces
paths
mod1
errs
<-
makeInterfaces
paths
mod1
...
...
src/Gen/GenFlatCurry.hs
View file @
ba21a418
...
@@ -47,7 +47,7 @@ trace' _ x = x
...
@@ -47,7 +47,7 @@ trace' _ x = x
-- transforms intermediate language code (IL) to FlatCurry code
-- transforms intermediate language code (IL) to FlatCurry code
genFlatCurry
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
genFlatCurry
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatCurry
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
genFlatCurry
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
prog'
,
messages
)
=
(
prog'
,
messages
)
where
(
prog
,
messages
)
where
(
prog
,
messages
)
...
@@ -57,7 +57,7 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
...
@@ -57,7 +57,7 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
genFlatInterface
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
WarnMsg
])
->
ArityEnv
->
IL
.
Module
->
(
Prog
,
[
Message
])
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
genFlatInterface
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
modul
=
(
patchPreludeFCY
intf
,
messages
)
(
patchPreludeFCY
intf
,
messages
)
where
(
intf
,
messages
)
where
(
intf
,
messages
)
...
@@ -120,7 +120,7 @@ data FlatEnv = FlatEnv
...
@@ -120,7 +120,7 @@ data FlatEnv = FlatEnv
,
varIndexE
::
Int
,
varIndexE
::
Int
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
varIdsE
::
ScopeEnv
Ident
VarIndex
,
tvarIndexE
::
Int
,
tvarIndexE
::
Int
,
messagesE
::
[
WarnMsg
]
,
messagesE
::
[
Message
]
,
genInterfaceE
::
Bool
,
genInterfaceE
::
Bool
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
localTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
,
constrTypes
::
Map
.
Map
QualIdent
IL
.
Type
...
@@ -132,7 +132,7 @@ data IdentExport = NotConstr -- function, type-constructor
...
@@ -132,7 +132,7 @@ data IdentExport = NotConstr -- function, type-constructor
-- Runs a 'FlatState' action and returns the result
-- Runs a 'FlatState' action and returns the result
run
::
Options
->
CurryEnv
->
ModuleEnv
->
ValueEnv
->
TCEnv
->
ArityEnv
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
run
opts
cEnv
mEnv
tyEnv
tcEnv
aEnv
genIntf
f
=
(
result
,
messagesE
env
)
=
(
result
,
messagesE
env
)
where
where
...
@@ -1084,7 +1084,7 @@ clearVarIndices = modify (\env -> env { varIndexE = 0,
...
@@ -1084,7 +1084,7 @@ clearVarIndices = modify (\env -> env { varIndexE = 0,
genWarning
::
String
->
FlatState
()
genWarning
::
String
->
FlatState
()
genWarning
msg
genWarning
msg
=
modify
(
\
env
->
env
{
messagesE
=
warnMsg
:
(
messagesE
env
)
})
=
modify
(
\
env
->
env
{
messagesE
=
warnMsg
:
(
messagesE
env
)
})
where
warnMsg
=
WarnMsg
Nothing
msg
where
warnMsg
=
Message
Nothing
msg
--
--
genInterface
::
FlatState
Bool
genInterface
::
FlatState
Bool
...
...
src/Html/SyntaxColoring.hs
View file @
ba21a418
...
@@ -43,7 +43,7 @@ data Code = Keyword String
...
@@ -43,7 +43,7 @@ data Code = Keyword String
|
CharCode
String
|
CharCode
String
|
Symbol
String
|
Symbol
String
|
Identifier
IdentifierKind
QualIdent
|
Identifier
IdentifierKind
QualIdent
|
CodeWarning
[
WarnMsg
]
Code
|
CodeWarning
[
Message
]
Code
|
NotParsed
String
|
NotParsed
String
deriving
Show
deriving
Show
...
@@ -114,10 +114,10 @@ getQualIdent _ = Nothing
...
@@ -114,10 +114,10 @@ getQualIdent _ = Nothing
-- DEBUGGING----------- wird bald nicht mehr gebraucht
-- DEBUGGING----------- wird bald nicht mehr gebraucht
setMessagePosition
::
WarnMsg
->
WarnMsg
setMessagePosition
::
Message
->
Message
setMessagePosition
m
@
(
WarnMsg
(
Just
p
)
_
)
=
trace''
(
"pos:"
++
show
p
++
":"
++
show
m
)
m
setMessagePosition
m
@
(
Message
(
Just
p
)
_
)
=
trace''
(
"pos:"
++
show
p
++
":"
++
show
m
)
m
setMessagePosition
(
WarnMsg
_
m
)
=
setMessagePosition
(
Message
_
m
)
=
let
mes
@
(
WarnMsg
pos
_
)
=
(
WarnMsg
(
getPositionFromString
m
)
m
)
in
let
mes
@
(
Message
pos
_
)
=
(
Message
(
getPositionFromString
m
)
m
)
in
trace''
(
"pos:"
++
show
pos
++
":"
++
show
mes
)
mes
trace''
(
"pos:"
++
show
pos
++
":"
++
show
mes
)
mes
getPositionFromString
::
String
->
Maybe
Position
getPositionFromString
::
String
->
Maybe
Position
...
@@ -144,28 +144,28 @@ flatCode code = code
...
@@ -144,28 +144,28 @@ flatCode code = code
-- ----------Message---------------------------------------
-- ----------Message---------------------------------------
getMessages
::
MsgMonad
a
->
[
WarnMsg
]
getMessages
::
MsgMonad
a
->
[
Message
]
getMessages
=
snd
.
runMsg
--(Result mess _) = mess
getMessages
=
snd
.
runMsg
--(Result mess _) = mess
-- getMessages (Failure mess) = mess
-- getMessages (Failure mess) = mess
lessMessage
::
WarnMsg
->
WarnMsg
->
Bool
lessMessage
::
Message
->
Message
->
Bool
lessMessage
(
WarnMsg
mPos1
_
)
(
WarnMsg
mPos2
_
)
=
mPos1
<
mPos2
lessMessage
(
Message
mPos1
_
)
(
Message
mPos2
_
)
=
mPos1
<
mPos2
nubMessages
::
[
WarnMsg
]
->
[
WarnMsg
]
nubMessages
::
[
Message
]
->
[
Message
]
nubMessages
=
nubBy
eqMessage
nubMessages
=
nubBy
eqMessage
eqMessage
::
WarnMsg
->
WarnMsg
->
Bool
eqMessage
::
Message
->
Message
->
Bool
eqMessage
(
WarnMsg
p1
s1
)
(
WarnMsg
p2
s2
)
=
(
p1
==
p2
)
&&
(
s1
==
s2
)
eqMessage
(
Message
p1
s1
)
(
Message
p2
s2
)
=
(
p1
==
p2
)
&&
(
s1
==
s2
)
prepareMessages
::
[
WarnMsg
]
->
[
WarnMsg
]
prepareMessages
::
[
Message
]
->
[
Message
]
prepareMessages
=
qsort
lessMessage
.
map
setMessagePosition
.
nubMessages
prepareMessages
=
qsort
lessMessage
.
map
setMessagePosition
.
nubMessages
buildMessagesIntoPlainText
::
[
WarnMsg
]
->
String
->
Program
buildMessagesIntoPlainText
::
[
Message
]
->
String
->
Program
buildMessagesIntoPlainText
messages
text
=
buildMessagesIntoPlainText
messages
text
=
buildMessagesIntoPlainText'
messages
(
lines
text
)
[]
1
buildMessagesIntoPlainText'
messages
(
lines
text
)
[]
1
where
where
buildMessagesIntoPlainText'
::
[
WarnMsg
]
->
[
String
]
->
[
String
]
->
Int
->
Program
buildMessagesIntoPlainText'
::
[
Message
]
->
[
String
]
->
[
String
]
->
Int
->
Program
buildMessagesIntoPlainText'
_
[]
[]
_
=
buildMessagesIntoPlainText'
_
[]
[]
_
=
[]
[]
buildMessagesIntoPlainText'
_
[]
postStrs
ln
=
buildMessagesIntoPlainText'
_
[]
postStrs
ln
=
...
@@ -182,7 +182,7 @@ buildMessagesIntoPlainText messages text =
...
@@ -182,7 +182,7 @@ buildMessagesIntoPlainText messages text =
(
ln
,
1
,
NewLine
)
:
(
ln
,
1
,
NewLine
)
:
buildMessagesIntoPlainText'
post
preStrs
[]
(
ln
+
1
)
buildMessagesIntoPlainText'
post
preStrs
[]
(
ln
+
1
)
where
where
isLeq
(
WarnMsg
(
Just
p
)
_
)
=
line
p
<=
ln
isLeq
(
Message
(
Just
p
)
_
)
=
line
p
<=
ln
isLeq
_
=
True
isLeq
_
=
True