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
0763bae0
Commit
0763bae0
authored
Sep 05, 2011
by
Björn Peemöller
Browse files
Checks improved
parent
6bef7507
Changes
8
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Checks.hs
View file @
0763bae0
...
...
@@ -13,8 +13,9 @@
-}
module
Checks
where
import
Curry.Base.MessageMonad
(
Message
)
import
Curry.Syntax
import
Curry.Syntax
(
Module
(
..
))
import
Base.Messages
import
qualified
Checks.KindCheck
as
KC
(
kindCheck
)
import
qualified
Checks.PrecCheck
as
PC
(
precCheck
)
...
...
@@ -25,36 +26,51 @@ import qualified Checks.WarnCheck as WC (warnCheck)
import
CompilerEnv
import
CompilerOpts
data
CheckStatus
a
=
CheckFailed
[
Message
]
|
CheckSuccess
a
instance
Monad
CheckStatus
where
return
=
CheckSuccess
m
>>=
f
=
case
m
of
CheckFailed
errs
->
CheckFailed
errs
CheckSuccess
a
->
f
a
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
kindCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
kindCheck
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
ds'
,
env
)
where
ds'
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
ds
kindCheck
::
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
kindCheck
env
(
Module
m
es
is
ds
)
|
null
msgs
=
(
env
,
Module
m
es
is
ds'
)
|
otherwise
=
errorMessages
msgs
where
(
ds'
,
msgs
)
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
ds
-- |Apply the precendences of infix operators.
-- This function reanrranges the AST.
precCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
precCheck
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
ds'
,
env
{
opPrecEnv
=
pEnv'
})
where
(
pEnv'
,
ds'
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
ds
precCheck
::
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
precCheck
env
(
Module
m
es
is
ds
)
|
null
msgs
=
(
env
{
opPrecEnv
=
pEnv'
},
Module
m
es
is
ds'
)
|
otherwise
=
errorMessages
msgs
where
(
ds'
,
pEnv'
,
msgs
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
ds
-- |Apply the syntax check.
syntaxCheck
::
Options
->
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
syntaxCheck
opts
(
Module
m
es
is
ds
)
env
=
(
Module
m
es
is
ds'
,
env
)
where
ds'
=
SC
.
syntaxCheck
withExt
(
moduleIdent
env
)
(
aliasEnv
env
)
syntaxCheck
::
Options
->
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
syntaxCheck
opts
env
(
Module
m
es
is
ds
)
|
null
msgs
=
(
env
,
Module
m
es
is
ds'
)
|
otherwise
=
errorMessages
msgs
where
(
ds'
,
msgs
)
=
SC
.
syntaxCheck
opts
(
moduleIdent
env
)
(
aliasEnv
env
)
(
arityEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
ds
withExt
=
BerndExtension
`
elem
`
optExtensions
opts
-- |Apply the type check.
typeCheck
::
Module
->
CompilerEnv
->
(
Module
,
CompilerEnv
)
typeCheck
mdl
@
(
Module
_
_
_
ds
)
env
=
(
mdl
,
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
})
typeCheck
::
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
typeCheck
env
mdl
@
(
Module
_
_
_
ds
)
=
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
}
,
mdl
)
where
(
tcEnv'
,
tyEnv'
)
=
TC
.
typeCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
ds
-- TODO: Which kind of warnings?
-- |Check for warnings.
warnCheck
::
Module
->
CompilerEnv
->
[
Message
]
warnCheck
(
Module
_
_
is
ds
)
env
warnCheck
::
CompilerEnv
->
Module
->
[
Message
]
warnCheck
env
(
Module
_
_
is
ds
)
=
WC
.
warnCheck
(
moduleIdent
env
)
(
valueEnv
env
)
is
ds
src/Checks/KindCheck.lhs
View file @
0763bae0
This diff is collapsed.
Click to expand it.
src/Checks/PrecCheck.lhs
View file @
0763bae0
This diff is collapsed.
Click to expand it.
src/Checks/SyntaxCheck.lhs
View file @
0763bae0
This diff is collapsed.
Click to expand it.
src/Checks/TypeCheck.lhs
View file @
0763bae0
...
...
@@ -39,11 +39,11 @@ type annotation is present.
>
import
Base.Expr
>
import
Base.Messages
(
errorAt
,
errorAt'
,
internalError
)
>
import
Base.SCC
>
import
Base.TopEnv
>
import
Base.Types
>
import
Base.TypeSubst
>
import
Base.Utils
(
foldr2
)
>
import
Env.TopEnv
>
import
Env.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
bindTypeInfo
,
qualLookupTC
)
>
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
bindFun
,
rebindFun
>
,
bindGlobalInfo
,
bindLabel
,
lookupValue
,
qualLookupValue
)
...
...
@@ -1246,17 +1246,18 @@ know that they are closed.
Miscellaneous functions.
\begin{verbatim}
>
remove
::
Eq
a
=>
a
->
[(
a
,
b
)]
->
[(
a
,
b
)]
>
remove
_
[]
=
[]
>
remove
k
((
k'
,
e
)
:
kes
)
|
k
==
k'
=
kes
> | otherwise = (k',e):(remove k kes)
>
remove
::
Eq
a
=>
a
->
[(
a
,
b
)]
->
[(
a
,
b
)]
>
remove
_
[]
=
[]
>
remove
k
(
kv
:
kvs
)
>
|
k
==
fst
kv
=
kvs
>
|
otherwise
=
kv
:
remove
k
kvs
\end{verbatim}
Error functions.
\begin{verbatim}
>
recursiveTypes
::
[
Ident
]
->
(
Position
,
String
)
>
recursiveTypes
[]
=
error
"TypeCheck.recursiveTypes: empty list"
>
recursiveTypes
[]
=
error
"TypeCheck.recursiveTypes: empty list"
>
recursiveTypes
[
tc
]
=
>
(
positionOfIdent
tc
,
>
"Recursive synonym type "
++
name
tc
)
...
...
src/Checks/WarnCheck.hs
View file @
0763bae0
...
...
@@ -23,7 +23,8 @@ import Curry.Base.Position
import
Curry.Base.MessageMonad
import
Curry.Syntax
import
qualified
Env.ScopeEnv
as
ScopeEnv
import
qualified
Base.ScopeEnv
as
ScopeEnv
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
qualLookupValue
)
...
...
src/CompilerOpts.hs
View file @
0763bae0
...
...
@@ -42,7 +42,7 @@ data Options = Options
,
optOverlapWarn
::
Bool
-- ^ show "overlap" warnings
,
optTargetTypes
::
[
TargetType
]
-- ^ what to generate
,
optExtensions
::
[
Extension
]
-- ^ enabled language extensions
,
optDumps
::
[
DumpLevel
]
-- ^ dumps
,
optDumps
::
[
DumpLevel
]
-- ^ dump
level
s
}
-- | Default compiler options
...
...
@@ -85,9 +85,6 @@ classifyVerbosity :: String -> Verbosity
classifyVerbosity
"0"
=
Quiet
classifyVerbosity
_
=
Verbose
-- TODO: dump FlatCurry code, dump AbstractCurry code, dump after 'case'
-- expansion
-- |Data type for representing code dumps
data
DumpLevel
=
DumpRenamed
-- ^ dump source after renaming
...
...
@@ -96,7 +93,7 @@ data DumpLevel
|
DumpSimplified
-- ^ dump source after simplification
|
DumpLifted
-- ^ dump source after lambda-lifting
|
DumpIL
-- ^ dump IL code after translation
|
DumpCase
-- ^ dump IL code after case
elimina
tion
|
DumpCase
-- ^ dump IL code after case
comple
tion
deriving
(
Eq
,
Bounded
,
Enum
,
Show
)
-- |All available 'DumpLevel's
...
...
@@ -105,14 +102,17 @@ dumpAll = [minBound .. maxBound]
-- |Data type representing language extensions
data
Extension
=
BerndExtension
-- TODO: Give it a more concise name
|
Records
|
FunctionPatterns
=
Records
|
FunctionalPatterns
|
AnonymousFreeVariables
|
NoImplicitPrelude
|
UnknownExtension
String
deriving
(
Eq
,
Read
,
Show
)
-- |'Extension's available by @-e@ flag
pakcsExtensions
::
[
Extension
]
pakcsExtensions
=
[
Records
,
FunctionalPatterns
]
-- |Classifies a 'String' as an 'Extension'
classifyExtension
::
String
->
Extension
classifyExtension
str
=
case
reads
str
of
...
...
@@ -190,7 +190,7 @@ options =
-- extensions
,
Option
"e"
[
"extended"
]
(
NoArg
(
\
opts
->
opts
{
optExtensions
=
nub
$
Bernd
Extension
:
optExtensions
opts
}))
nub
$
pakcs
Extension
s
++
optExtensions
opts
}))
"enable extended Curry functionalities"
,
Option
"X"
[]
(
ReqArg
(
\
arg
opts
->
opts
{
optExtensions
=
...
...
src/Modules.lhs
View file @
0763bae0
...
...
@@ -21,7 +21,7 @@ This module controls the compilation of modules.
\begin{verbatim}
>
module
Modules
>
(
compileModule
,
loadModule
,
checkModuleHeader
,
simpleCheckModule
,
checkModule
>
(
compileModule
,
loadModule
,
checkModuleHeader
,
checkModule
>
)
where
>
import
Control.Monad
(
liftM
,
unless
,
when
)
...
...
@@ -83,34 +83,23 @@ code are obsolete and commented out.
>
compileModule
::
Options
->
FilePath
->
IO
()
>
compileModule
opts
fn
=
do
>
(
env
,
mdl
)
<-
loadModule
opts
fn
>
if
not
withFlat
>
then
do
>
let
(
env2
,
modul
,
_intf
,
warnMsgs
)
=
simpleCheckModule
opts
env
mdl
>
showWarnings
opts
warnMsgs
>
-- output the parsed source
>
writeParsed
opts
fn
modul
>
-- output AbstractCurry
>
writeAbstractCurry
opts
fn
env2
modul
>
else
do
>
-- checkModule checks types, and then transModule introduces new
>
-- functions (by lambda lifting in 'desugar'). Consequence: The
>
-- types of the newly introduced functions are not inferred (hsi)
>
let
(
env2
,
modul
,
intf
,
warnMsgs
)
=
checkModule
opts
env
mdl
>
showWarnings
opts
warnMsgs
>
writeParsed
opts
fn
modul
>
writeAbstractCurry
opts
fn
env2
modul
>
let
(
env3
,
il
,
dumps
)
=
transModule
opts
env2
modul
>
-- dump intermediate results
>
mapM_
(
doDump
opts
)
dumps
>
-- generate target code
>
let
modSum
=
summarizeModule
(
tyConsEnv
env3
)
intf
modul
>
writeFlat
opts
fn
env3
modSum
il
>
(
env
,
modul
,
intf
,
warnings
)
<-
uncurry
(
checkModule
opts
)
`
liftM
`
loadModule
opts
fn
>
showWarnings
opts
$
warnings
>
writeParsed
opts
fn
modul
>
writeAbstractCurry
opts
fn
env
modul
>
when
withFlat
$
do
>
-- checkModule checks types, and then transModule introduces new
>
-- functions (by lambda lifting in 'desugar'). Consequence: The
>
-- types of the newly introduced functions are not inferred (hsi)
>
let
(
env2
,
il
,
dumps
)
=
transModule
opts
env
modul
>
-- dump intermediate results
>
mapM_
(
doDump
opts
)
dumps
>
-- generate target code
>
let
modSum
=
summarizeModule
(
tyConsEnv
env2
)
intf
modul
>
writeFlat
opts
fn
env2
modSum
il
>
where
>
fcyTarget
=
FlatCurry
`
elem
`
optTargetTypes
opts
>
xmlTarget
=
FlatXml
`
elem
`
optTargetTypes
opts
>
extTarget
=
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
>
withFlat
=
or
[
fcyTarget
,
xmlTarget
,
extTarget
]
>
withFlat
=
any
(`
elem
`
optTargetTypes
opts
)
>
[
FlatCurry
,
FlatXml
,
ExtendedFlatCurry
]
-- ---------------------------------------------------------------------------
-- Loading a module
...
...
@@ -185,38 +174,22 @@ Haskell and original MCC where a module obtains \texttt{main}).
-- Checking a module
-- ---------------------------------------------------------------------------
>
-- |
>
simpleCheckModule
::
Options
->
CompilerEnv
->
CS
.
Module
>
->
(
CompilerEnv
,
CS
.
Module
,
CS
.
Interface
,
[
Message
])
>
simpleCheckModule
opts
env
mdl
=
(
env3
,
mdl2
,
intf
,
warnMsgs
)
>
where
>
-- check for warnings
>
warnMsgs
=
warnCheck
mdl
env
>
-- check kinds, syntax, precedence
>
(
mdl2
,
env2
)
=
uncurry
qual
>
$
uncurry
precCheck
>
$
uncurry
(
syntaxCheck
opts
)
>
$
uncurry
kindCheck
>
(
mdl
,
env
)
>
env3
=
qualifyEnv
opts
env2
>
intf
=
exportInterface
env3
mdl2
>
checkModule
::
Options
->
CompilerEnv
->
CS
.
Module
>
->
(
CompilerEnv
,
CS
.
Module
,
CS
.
Interface
,
[
Message
])
>
checkModule
opts
env
mdl
=
(
env
3
,
mdl
3
,
intf
,
warn
Ms
gs
)
>
checkModule
opts
env
mdl
=
(
env
'
,
mdl
'
,
intf
,
warn
in
gs
)
>
where
>
-- check for warnings
>
warnMsgs
=
warnCheck
mdl
env
>
-- check kinds, syntax, precedence, types
>
(
mdl2
,
env2
)
=
uncurry
qual
>
$
uncurry
typeCheck
>
warnings
=
warnCheck
env
mdl
>
intf
=
exportInterface
env'
mdl'
>
(
env'
,
mdl'
)
=
qualifyE
$
expand
$
uncurry
qual
>
$
(
if
withFlat
then
uncurry
typeCheck
else
id
)
>
$
uncurry
precCheck
>
$
uncurry
(
syntaxCheck
opts
)
>
$
uncurry
kindCheck
>
(
mdl
,
env
)
>
mdl3
=
expandInterface
env2
$
mdl2
>
env3
=
qualifyEnv
opts
env2
>
intf
=
exportInterface
env3
mdl3
>
(
env
,
mdl
)
>
expand
(
e
,
m
)
=
if
withFlat
then
(
e
,
expandInterface
e
m
)
else
(
e
,
m
)
>
qualifyE
(
e
,
m
)
=
(
qualifyEnv
opts
e
,
m
)
>
withFlat
=
any
(`
elem
`
optTargetTypes
opts
)
>
[
FlatCurry
,
FlatXml
,
ExtendedFlatCurry
]
-- ---------------------------------------------------------------------------
-- Translating a module
...
...
@@ -266,8 +239,7 @@ be dependent on it any longer.
>
targetFile
=
fromMaybe
(
sourceRepName
fn
)
(
optOutput
opts
)
>
source
=
CS
.
showModule
modul
>
writeFlat
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
>
->
IL
.
Module
->
IO
()
>
writeFlat
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
->
IL
.
Module
->
IO
()
>
writeFlat
opts
fn
env
modSum
il
=
do
>
writeFlatCurry
opts
fn
env
modSum
il
>
writeInterface
opts
fn
env
modSum
il
...
...
@@ -289,8 +261,9 @@ be dependent on it any longer.
>
writeInterface
::
Options
->
FilePath
->
CompilerEnv
->
ModuleSummary
>
->
IL
.
Module
->
IO
()
>
writeInterface
opts
fn
env
modSum
il
>
|
optForce
opts
=
outputInterface
>
|
otherwise
=
do
>
|
not
(
optInterface
opts
)
=
return
()
>
|
optForce
opts
=
outputInterface
>
|
otherwise
=
do
>
mfint
<-
EF
.
readFlatInterface
targetFile
>
let
oldInterface
=
fromMaybe
emptyIntf
mfint
>
when
(
mfint
==
mfint
)
$
return
()
-- necessary to close file -- TODO
...
...
@@ -345,6 +318,6 @@ standard output.
>
dumpHeader
DumpSimplified
=
"Source code after simplification"
>
dumpHeader
DumpLifted
=
"Source code after lifting"
>
dumpHeader
DumpIL
=
"Intermediate code"
>
dumpHeader
DumpCase
=
"Intermediate code after case
si
mpl
ifica
tion"
>
dumpHeader
DumpCase
=
"Intermediate code after case
co
mpl
e
tion"
\end{verbatim}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment