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
a35f0d57
Commit
a35f0d57
authored
Sep 06, 2011
by
Björn Peemöller
Browse files
small refactorings
parent
0763bae0
Changes
8
Expand all
Hide whitespace changes
Inline
Side-by-side
src/Checks.hs
View file @
a35f0d57
...
...
@@ -39,22 +39,17 @@ instance Monad CheckStatus where
-- TODO: More documentation
-- |Check the kinds of type definitions and signatures.
-- In addition, nullary type constructors and type variables are dinstiguished
-- In addition, nullary type constructors and type variables are
-- disambiguated in the declarations; the environment remains unchanged.
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
::
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.
-- |Check for a correct syntax.
-- In addition, nullary data constructors and variables are
-- disambiguated in the declarations; the environment remains unchanged.
syntaxCheck
::
Options
->
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
syntaxCheck
opts
env
(
Module
m
es
is
ds
)
|
null
msgs
=
(
env
,
Module
m
es
is
ds'
)
...
...
@@ -62,7 +57,18 @@ syntaxCheck opts env (Module m es is ds)
where
(
ds'
,
msgs
)
=
SC
.
syntaxCheck
opts
(
moduleIdent
env
)
(
aliasEnv
env
)
(
arityEnv
env
)
(
valueEnv
env
)
(
tyConsEnv
env
)
ds
-- |Apply the type check.
-- |Check the precedences of infix operators.
-- In addition, the abstract syntax tree is rearranged to reflect the
-- relative precedences; the operator precedence environment is updated.
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 correct typing of the module.
-- The declarations remain unchanged; the type constructor and value
-- environments are updated.
typeCheck
::
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
)
typeCheck
env
mdl
@
(
Module
_
_
_
ds
)
=
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
},
mdl
)
where
(
tcEnv'
,
tyEnv'
)
=
TC
.
typeCheck
(
moduleIdent
env
)
...
...
@@ -72,5 +78,4 @@ typeCheck env mdl@(Module _ _ _ ds) = (env { tyConsEnv = tcEnv', valueEnv = tyEn
-- |Check for warnings.
warnCheck
::
CompilerEnv
->
Module
->
[
Message
]
warnCheck
env
(
Module
_
_
is
ds
)
=
WC
.
warnCheck
(
moduleIdent
env
)
(
valueEnv
env
)
is
ds
warnCheck
env
mdl
=
WC
.
warnCheck
(
valueEnv
env
)
mdl
src/Checks/PrecCheck.lhs
View file @
a35f0d57
...
...
@@ -30,7 +30,8 @@ of the operators involved.
>
import
Base.Messages
(
Message
,
toMessage
)
>
import
Base.Utils
(
findDouble
)
>
import
Env.OpPrec
(
PEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
,
qualLookupP
)
>
import
Env.OpPrec
(
PEnv
,
OpPrec
(
..
),
PrecInfo
(
..
),
defaultP
,
bindP
>
,
qualLookupP
)
>
precCheck
::
ModuleIdent
->
PEnv
->
[
Decl
]
->
([
Decl
],
PEnv
,
[
Message
])
>
precCheck
m
pEnv
decls
=
runPCM
(
checkDecls
decls
)
initState
...
...
@@ -58,14 +59,14 @@ The Prec check monad.
>
getPrecEnv
::
PCM
PEnv
>
getPrecEnv
=
S
.
gets
precEnv
>
with
PrecEnv
::
(
PEnv
->
PEnv
)
->
PCM
()
>
with
PrecEnv
f
=
S
.
modify
$
\
s
->
s
{
precEnv
=
f
$
precEnv
s
}
>
modify
PrecEnv
::
(
PEnv
->
PEnv
)
->
PCM
()
>
modify
PrecEnv
f
=
S
.
modify
$
\
s
->
s
{
precEnv
=
f
$
precEnv
s
}
>
withLocalPrecEnv
::
PCM
a
->
PCM
a
>
withLocalPrecEnv
act
=
do
>
oldEnv
<-
getPrecEnv
>
res
<-
act
>
with
PrecEnv
$
const
oldEnv
>
modify
PrecEnv
$
const
oldEnv
>
return
res
>
report
::
Message
->
PCM
()
...
...
@@ -83,10 +84,10 @@ imported precedence environment.
>
bindPrecs
ds
=
case
findDouble
opFixDecls
of
>
Just
op
->
report
$
errDuplicatePrecedence
op
>
Nothing
->
case
filter
(`
notElem
`
bvs
)
opFixDecls
of
>
op
:
_
->
report
$
errUndefinedOperator
op
>
op
:
_
->
report
$
errUndefinedOperator
op
>
[]
->
do
>
m
<-
getModuleIdent
>
with
PrecEnv
$
\
env
->
foldr
(
bindPrec
m
)
env
fixDs
>
modify
PrecEnv
$
\
env
->
foldr
(
bindPrec
m
)
env
fixDs
>
where
>
(
fixDs
,
nonFixDs
)
=
partition
isInfixDecl
ds
>
opFixDecls
=
[
op
|
InfixDecl
_
_
_
ops
<-
fixDs
,
op
<-
ops
]
...
...
@@ -137,12 +138,11 @@ interface.
>
liftM2
(
Equation
p
)
(
checkLhs
lhs
)
(
checkRhs
rhs
)
>
checkLhs
::
Lhs
->
PCM
Lhs
>
checkLhs
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
checkConstrTerm
ts
>
checkLhs
(
FunLhs
f
ts
)
=
FunLhs
f
`
liftM
`
mapM
checkConstrTerm
ts
>
checkLhs
(
OpLhs
t1
op
t2
)
=
>
liftM2
(
\
u1
u2
->
OpLhs
u1
op
u2
)
t1'
t2'
>
where
t1'
=
(
checkConstrTerm
t1
>>=
checkOpL
op
)
>
t2'
=
(
checkConstrTerm
t2
>>=
checkOpR
op
)
>
checkLhs
(
ApLhs
lhs
ts
)
=
>
liftM2
(
flip
OpLhs
op
)
(
checkConstrTerm
t1
>>=
checkOpL
op
)
>
(
checkConstrTerm
t2
>>=
checkOpR
op
)
>
checkLhs
(
ApLhs
lhs
ts
)
=
>
liftM2
ApLhs
(
checkLhs
lhs
)
(
mapM
checkConstrTerm
ts
)
>
checkConstrTerm
::
ConstrTerm
->
PCM
ConstrTerm
...
...
src/Checks/TypeCheck.lhs
View file @
a35f0d57
...
...
@@ -64,13 +64,13 @@ constructor and type environments.
\begin{verbatim}
>
typeCheck
::
ModuleIdent
->
TCEnv
->
ValueEnv
->
[
Decl
]
->
(
TCEnv
,
ValueEnv
)
>
typeCheck
m
tcEnv
tyEnv
ds
=
>
run
(
tcDecls
m
tcEnv'
Map
.
empty
v
d
s
>>
>
typeCheck
m
tcEnv
tyEnv
d
ecl
s
=
>
run
(
tcDecls
m
tcEnv'
Map
.
empty
v
alueDecl
s
>>
>
S
.
lift
S
.
get
>>=
\
theta
->
S
.
get
>>=
\
tyEnv'
->
>
return
(
tcEnv'
,
subst
theta
tyEnv'
))
>
(
bindLabels
m
tcEnv'
(
bindConstrs
m
tcEnv'
tyEnv
))
>
where
(
t
ds
,
vd
s
)
=
partition
isTypeDecl
ds
>
tcEnv'
=
bindTypes
m
t
d
s
tcEnv
>
return
(
tcEnv'
,
subst
theta
tyEnv'
))
>
(
bindLabels
m
tcEnv'
(
bindConstrs
m
tcEnv'
tyEnv
))
-- initEnv
>
where
(
t
ypeDecls
,
valueDecl
s
)
=
partition
isTypeDecl
d
ecl
s
>
tcEnv'
=
bindTypes
m
t
ypeDecl
s
tcEnv
\end{verbatim}
...
...
@@ -172,19 +172,19 @@ have been properly renamed and all type synonyms are already expanded.
\begin{verbatim}
>
bindConstrs
::
ModuleIdent
->
TCEnv
->
ValueEnv
->
ValueEnv
>
bindConstrs
m
tcEnv
tyEnv
=
>
foldr
(
bindData
.
snd
)
tyEnv
(
localBindings
tcEnv
)
>
where
bindData
(
DataType
tc
n
cs
)
tyEnv'
=
>
foldr
(
bindConstr
m
n
(
constrType'
tc
n
))
tyEnv'
(
catMaybes
cs
)
>
bindData
(
RenamingType
tc
n
(
DataConstr
c
n'
[
ty
]))
tyEnv'
=
>
bindGlobalInfo
NewtypeConstructor
m
c
>
(
ForAllExist
n
n'
(
TypeArrow
ty
(
constrType'
tc
n
)))
>
tyEnv'
>
bindData
(
AliasType
_
_
_
)
tyEnv'
=
tyEnv'
>
bindConstr
m'
n
ty
(
DataConstr
c
n'
tys
)
=
>
bindGlobalInfo
DataConstructor
m'
c
>
(
ForAllExist
n
n'
(
foldr
TypeArrow
ty
tys
))
>
constrType'
tc
n
=
TypeConstructor
tc
(
map
TypeVariable
[
0
..
n
-
1
])
>
bindConstrs
m
tcEnv
tyEnv
=
foldr
(
bindData
.
snd
)
tyEnv
(
localBindings
tcEnv
)
>
where
>
bindData
(
DataType
tc
n
cs
)
tyEnv'
=
>
foldr
(
bindConstr
m
n
(
constrType'
tc
n
))
tyEnv'
(
catMaybes
cs
)
>
bindData
(
RenamingType
tc
n
(
DataConstr
c
n'
[
ty
]))
tyEnv'
=
>
bindGlobalInfo
NewtypeConstructor
m
c
>
(
ForAllExist
n
n'
(
TypeArrow
ty
(
constrType'
tc
n
)))
>
tyEnv'
>
bindData
(
AliasType
_
_
_
)
tyEnv'
=
tyEnv'
>
bindConstr
m'
n
ty
(
DataConstr
c
n'
tys
)
=
>
bindGlobalInfo
DataConstructor
m'
c
>
(
ForAllExist
n
n'
(
foldr
TypeArrow
ty
tys
))
>
constrType'
tc
n
=
TypeConstructor
tc
(
map
TypeVariable
[
0
..
n
-
1
])
\end{verbatim}
\paragraph{Defining Field Labels}
...
...
src/Checks/WarnCheck.hs
View file @
a35f0d57
This diff is collapsed.
Click to expand it.
src/CompilerEnv.hs
View file @
a35f0d57
...
...
@@ -39,7 +39,7 @@ data CompilerEnv = CompilerEnv
,
labelEnv
::
LabelEnv
-- ^ record labels
,
opPrecEnv
::
PEnv
-- ^ operator precedences
,
tyConsEnv
::
TCEnv
-- ^ type constructors
,
valueEnv
::
ValueEnv
-- ^ functions
, ...
,
valueEnv
::
ValueEnv
-- ^ functions
and data constructors
}
initCompilerEnv
::
ModuleIdent
->
CompilerEnv
...
...
src/Frontend.hs
View file @
a35f0d57
...
...
@@ -24,7 +24,7 @@ import Control.Monad.Writer
import
Curry.Base.MessageMonad
import
Curry.Files.Filenames
import
Curry.Files.PathUtils
import
Curry.Syntax
(
Module
(
..
),
Interface
,
parseModule
)
import
Curry.Syntax
(
Module
(
..
),
parseModule
)
import
CompilerEnv
import
CompilerOpts
(
Options
(
..
),
Verbosity
(
..
),
TargetType
(
..
),
defaultOptions
)
...
...
@@ -68,7 +68,7 @@ genCurrySyntax fn mod1
--
genFullCurrySyntax
::
(
Options
->
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
,
Interface
,
[
Message
]
))
(
Options
->
CompilerEnv
->
Module
->
(
CompilerEnv
,
Module
))
->
[
FilePath
]
->
FilePath
->
MsgMonad
Module
->
IO
(
MsgMonad
Module
)
genFullCurrySyntax
check
paths
fn
m
=
runMsgIO
m
$
\
mod1
->
do
errs
<-
makeInterfaces
paths
fn
mod1
...
...
@@ -76,8 +76,8 @@ genFullCurrySyntax check paths fn m = runMsgIO m $ \mod1 -> do
then
do
iEnv
<-
loadInterfaces
paths
mod1
let
env
=
importModules
opts
mod1
iEnv
(
_
,
mod'
,
_
,
msgs
)
=
check
opts
env
mod1
return
(
tell
msgs
>>
return
mod'
)
(
_
,
mod'
)
=
check
opts
env
mod1
return
(
return
mod'
)
else
return
$
failWith
$
head
errs
where
opts
=
mkOpts
paths
...
...
src/Imports.hs
View file @
a35f0d57
...
...
@@ -39,10 +39,6 @@ import CompilerEnv
import
CompilerOpts
import
Records
(
importLabels
,
recordExpansion1
,
recordExpansion2
)
-- ---------------------------------------------------------------------------
-- Interface
-- ---------------------------------------------------------------------------
-- |The function 'importModules' brings the declarations of all
-- imported interfaces into scope for the current module.
importModules
::
Options
->
Module
->
InterfaceEnv
->
CompilerEnv
...
...
@@ -61,15 +57,6 @@ importModules opts (Module mid _ imps _) iEnv
Nothing
->
internalError
$
"Imports.importModules: no interface for "
++
show
m
-- |
qualifyEnv
::
Options
->
CompilerEnv
->
CompilerEnv
qualifyEnv
opts
env
=
recordExpansion2
opts
$
qualifyLocal
env
$
foldl
(
flip
importInterfaceIntf
)
initEnv
$
Map
.
elems
$
interfaceEnv
env
where
initEnv
=
initCompilerEnv
$
moduleIdent
env
-- ---------------------------------------------------------------------------
-- Importing an interface into the module
-- ---------------------------------------------------------------------------
...
...
@@ -390,6 +377,15 @@ importUnifyData' tcEnv = fmap (setInfo allTyCons) tcEnv
-- ---------------------------------------------------------------------------
-- |
qualifyEnv
::
Options
->
CompilerEnv
->
CompilerEnv
qualifyEnv
opts
env
=
recordExpansion2
opts
$
qualifyLocal
env
$
foldl
(
flip
importInterfaceIntf
)
initEnv
$
Map
.
elems
$
interfaceEnv
env
where
initEnv
=
initCompilerEnv
$
moduleIdent
env
qualifyLocal
::
CompilerEnv
->
CompilerEnv
->
CompilerEnv
qualifyLocal
currentEnv
initEnv
=
currentEnv
{
opPrecEnv
=
foldr
bindQual
pEnv
$
localBindings
$
opPrecEnv
currentEnv
...
...
src/Modules.lhs
View file @
a35f0d57
...
...
@@ -83,8 +83,9 @@ code are obsolete and commented out.
>
compileModule
::
Options
->
FilePath
->
IO
()
>
compileModule
opts
fn
=
do
>
(
env
,
modul
,
intf
,
warnings
)
<-
uncurry
(
checkModule
opts
)
`
liftM
`
loadModule
opts
fn
>
showWarnings
opts
$
warnings
>
loaded
<-
loadModule
opts
fn
>
let
(
env
,
modul
)
=
uncurry
(
checkModule
opts
)
loaded
>
showWarnings
opts
$
uncurry
warnCheck
loaded
>
writeParsed
opts
fn
modul
>
writeAbstractCurry
opts
fn
env
modul
>
when
withFlat
$
do
...
...
@@ -95,6 +96,7 @@ code are obsolete and commented out.
>
-- dump intermediate results
>
mapM_
(
doDump
opts
)
dumps
>
-- generate target code
>
let
intf
=
exportInterface
env
modul
>
let
modSum
=
summarizeModule
(
tyConsEnv
env2
)
intf
modul
>
writeFlat
opts
fn
env2
modSum
il
>
where
...
...
@@ -174,22 +176,19 @@ Haskell and original MCC where a module obtains \texttt{main}).
-- Checking a module
-- ---------------------------------------------------------------------------
>
checkModule
::
Options
->
CompilerEnv
->
CS
.
Module
>
->
(
CompilerEnv
,
CS
.
Module
,
CS
.
Interface
,
[
Message
])
>
checkModule
opts
env
mdl
=
(
env'
,
mdl'
,
intf
,
warnings
)
>
checkModule
::
Options
->
CompilerEnv
->
CS
.
Module
->
(
CompilerEnv
,
CS
.
Module
)
>
checkModule
opts
env
mdl
=
qualifyEnvs
>
$
expand
>
$
uncurry
qual
>
$
(
if
withFlat
then
uncurry
typeCheck
else
id
)
>
$
uncurry
precCheck
>
$
uncurry
(
syntaxCheck
opts
)
>
$
kindCheck
env
mdl
>
where
>
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
>
(
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
]
>
expand
(
e
,
m
)
=
if
withFlat
then
(
e
,
expandInterface
e
m
)
else
(
e
,
m
)
>
qualifyEnvs
(
e
,
m
)
=
(
qualifyEnv
opts
e
,
m
)
>
withFlat
=
any
(`
elem
`
optTargetTypes
opts
)
>
[
FlatCurry
,
FlatXml
,
ExtendedFlatCurry
]
-- ---------------------------------------------------------------------------
-- Translating a module
...
...
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