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
90c3383e
Commit
90c3383e
authored
Aug 18, 2011
by
Björn Peemöller
Browse files
More refactorings
parent
34fddcdd
Changes
25
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
90c3383e
...
...
@@ -71,8 +71,8 @@ Executable cymake
, Env.Arity
, Env.Eval
, Env.Import
, Env.Interfaces
, Env.Label
, Env.Module
, Env.NestEnv
, Env.OldScopeEnv
, Env.OpPrec
...
...
src/Base/CurryTypes.lhs
View file @
90c3383e
...
...
@@ -44,7 +44,7 @@ order of type variables in the left hand side of a type declaration.
>
toType'
tvs
(
CS
.
ConstructorType
tc
tys
)
=
>
TypeConstructor
tc
(
map
(
toType'
tvs
)
tys
)
>
toType'
tvs
(
CS
.
VariableType
tv
)
=
>
maybe
(
internalError
(
"toType "
++
show
tv
)
)
TypeVariable
(
Map
.
lookup
tv
tvs
)
>
maybe
(
internalError
$
"toType "
++
show
tv
)
TypeVariable
(
Map
.
lookup
tv
tvs
)
>
toType'
tvs
(
CS
.
TupleType
tys
)
>
|
null
tys
=
TypeConstructor
(
qualify
unitId
)
[]
>
|
otherwise
=
TypeConstructor
(
qualify
(
tupleId
(
length
tys'
)))
tys'
...
...
src/Base/ErrorMessages.hs
0 → 100644
View file @
90c3383e
module
Base.ErrorMessages
where
import
Data.List
(
intercalate
)
import
Curry.Base.Ident
errCyclicImport
::
[
ModuleIdent
]
->
String
errCyclicImport
[]
=
error
"Base.ErrorMessages.errCyclicImport: empty list"
errCyclicImport
[
m
]
=
"Recursive import for module "
++
moduleName
m
errCyclicImport
ms
=
"Cylic import dependency between modules "
++
intercalate
", "
inits
++
" and "
++
lastm
where
(
inits
,
lastm
)
=
splitLast
$
map
moduleName
ms
splitLast
[]
=
error
"Base.ErrorMessages.splitLast: empty list"
splitLast
(
x
:
[]
)
=
(
[]
,
x
)
splitLast
(
x
:
y
:
ys
)
=
(
x
:
xs
,
z
)
where
(
xs
,
z
)
=
splitLast
(
y
:
ys
)
errMissingFile
::
FilePath
->
String
errMissingFile
f
=
"Missing file
\"
"
++
f
++
"
\"
"
errFileModuleMismatch
::
FilePath
->
ModuleIdent
->
String
errFileModuleMismatch
f
m
=
"File name '"
++
f
++
"' does not match module name '"
++
moduleName
m
++
"'"
errModuleFileMismatch
::
ModuleIdent
->
String
errModuleFileMismatch
mid
=
"module
\"
"
++
moduleName
mid
++
"
\"
must be in a file
\"
"
++
moduleName
mid
++
".(l)curry
\"
"
errWrongInterface
::
ModuleIdent
->
ModuleIdent
->
String
errWrongInterface
m
m'
=
"Expected interface for "
++
show
m
++
" but found "
++
show
m'
++
show
(
moduleQualifiers
m
,
moduleQualifiers
m'
)
errWrongModule
::
ModuleIdent
->
ModuleIdent
->
String
errWrongModule
m
m'
=
"Expected module for "
++
show
m
++
" but found "
++
show
m'
++
show
(
moduleQualifiers
m
,
moduleQualifiers
m'
)
errInterfaceNotFound
::
ModuleIdent
->
String
errInterfaceNotFound
m
=
"Interface for module "
++
moduleName
m
++
" not found"
errInterfaceModuleMismatch
::
ModuleIdent
->
ModuleIdent
->
String
errInterfaceModuleMismatch
mi
mm
=
"Interface "
++
show
mi
++
" does not match module "
++
show
mm
src/Base/Subst.lhs
View file @
90c3383e
...
...
@@ -14,8 +14,8 @@ marked with a boolean flag (see below).
>
module
Base.Subst
>
(
Subst
(
..
),
IntSubst
(
..
),
idSubst
,
substToList
,
bindSubst
,
unbindSubst
>
,
compose
,
substVar'
,
isubstVar
,
restrictSubstTo
>
)
where
>
,
compose
,
substVar'
,
isubstVar
,
restrictSubstTo
>
)
where
>
import
qualified
Data.Map
as
Map
...
...
src/Base/TypeSubst.lhs
View file @
90c3383e
...
...
@@ -9,7 +9,9 @@
This module implements substitutions on types.
\begin{verbatim}
>
module
Base.TypeSubst
(
module
Base
.
TypeSubst
,
idSubst
,
bindSubst
,
compose
)
where
>
module
Base.TypeSubst
>
(
module
Base.TypeSubst
,
idSubst
,
bindSubst
,
compose
>
)
where
>
import
Data.List
(
nub
)
>
import
Data.Maybe
(
fromJust
,
isJust
)
...
...
src/Base/Typing.lhs
View file @
90c3383e
...
...
@@ -19,7 +19,7 @@
>
import
Base.Messages
(
internalError
)
>
import
Base.Types
>
import
Base.TypeSubst
>
import
Base.Utils
>
import
Base.Utils
(
foldr2
)
>
import
Env.TopEnv
>
import
Env.Value
(
ValueEnv
,
ValueInfo
(
..
),
lookupValue
,
qualLookupValue
)
...
...
src/Base/Utils.lhs
View file @
90c3383e
...
...
@@ -11,8 +11,7 @@ commonly used in the compiler, but not implemented in the Haskell
\begin{verbatim}
>
module
Base.Utils
>
(
fst3
,
snd3
,
thd3
,
apFst3
,
apSnd3
,
apThd3
,
curry3
,
uncurry3
>
,
(
++!
),
foldl2
,
foldr2
,
mapAccumM
,
findDouble
>
(
thd3
,
(
++!
),
foldr2
,
mapAccumM
,
findDouble
>
)
where
>
infixr
5
++!
...
...
@@ -24,29 +23,29 @@ triples. We provide projection, (un-)currying, and mapping for triples
here.
\begin{verbatim}
>
fst3
::
(
a
,
b
,
c
)
->
a
>
fst3
(
x
,
_
,
_
)
=
x
fst3 :: (a, b, c) -> a
fst3 (x, _, _) = x
>
snd3
::
(
a
,
b
,
c
)
->
b
>
snd3
(
_
,
y
,
_
)
=
y
snd3 :: (a, b, c) -> b
snd3 (_, y, _) = y
>
thd3
::
(
a
,
b
,
c
)
->
c
>
thd3
(
_
,
_
,
z
)
=
z
>
apFst3
::
(
a
->
d
)
->
(
a
,
b
,
c
)
->
(
d
,
b
,
c
)
>
apFst3
f
(
x
,
y
,
z
)
=
(
f
x
,
y
,
z
)
apFst3 :: (a -> d) -> (a, b, c) -> (d, b, c)
apFst3 f (x, y, z) = (f x, y, z)
>
apSnd3
::
(
b
->
d
)
->
(
a
,
b
,
c
)
->
(
a
,
d
,
c
)
>
apSnd3
f
(
x
,
y
,
z
)
=
(
x
,
f
y
,
z
)
apSnd3 :: (b -> d) -> (a, b, c) -> (a, d, c)
apSnd3 f (x, y, z) = (x, f y, z)
>
apThd3
::
(
c
->
d
)
->
(
a
,
b
,
c
)
->
(
a
,
b
,
d
)
>
apThd3
f
(
x
,
y
,
z
)
=
(
x
,
y
,
f
z
)
apThd3 :: (c -> d) -> (a, b, c) -> (a, b, d)
apThd3 f (x, y, z) = (x, y, f z)
>
curry3
::
((
a
,
b
,
c
)
->
d
)
->
a
->
b
->
c
->
d
>
curry3
f
x
y
z
=
f
(
x
,
y
,
z
)
curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 f x y z = f (x, y, z)
>
uncurry3
::
(
a
->
b
->
c
->
d
)
->
(
a
,
b
,
c
)
->
d
>
uncurry3
f
(
x
,
y
,
z
)
=
f
x
y
z
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (x, y, z) = f x y z
\end{verbatim}
\paragraph{Lists}
...
...
@@ -79,10 +78,10 @@ Fold operations with two arguments lists can be defined using
definitions are unfolded for efficiency reasons.
\begin{verbatim}
>
foldl2
::
(
a
->
b
->
c
->
a
)
->
a
->
[
b
]
->
[
c
]
->
a
>
foldl2
_
z
[]
_
=
z
>
foldl2
_
z
_
[]
=
z
>
foldl2
f
z
(
x
:
xs
)
(
y
:
ys
)
=
foldl2
f
(
f
z
x
y
)
xs
ys
foldl2 :: (a -> b -> c -> a) -> a -> [b] -> [c] -> a
foldl2 _ z [] _ = z
foldl2 _ z _ [] = z
foldl2 f z (x : xs) (y : ys) = foldl2 f (f z x y) xs ys
>
foldr2
::
(
a
->
b
->
c
->
c
)
->
c
->
[
a
]
->
[
b
]
->
c
>
foldr2
_
z
[]
_
=
z
...
...
src/Check/TypeCheck.lhs
View file @
90c3383e
...
...
@@ -41,7 +41,7 @@ type annotation is present.
>
import
Base.SCC
>
import
Base.Types
>
import
Base.TypeSubst
>
import
Base.Utils
>
import
Base.Utils
(
foldr2
)
>
import
Env.TopEnv
>
import
Env.TypeConstructors
(
TCEnv
,
TypeInfo
(
..
),
bindTypeInfo
,
qualLookupTC
)
...
...
src/Check/WarnCheck.hs
View file @
90c3383e
...
...
@@ -211,7 +211,7 @@ checkExpression mid (Tuple _ exprs)
checkExpression
mid
(
List
_
exprs
)
=
foldM'
(
checkExpression
mid
)
exprs
checkExpression
mid
(
ListCompr
_
expr
stmts
)
=
withScope
$
do
foldM'
(
C
heck
M
ment
mid
)
stmts
foldM'
(
c
heck
State
ment
mid
)
stmts
checkExpression
mid
expr
idents'
<-
returnUnrefVars
when
(
not
$
null
idents'
)
$
foldM'
genWarning'
$
map
unrefVar
idents'
...
...
@@ -249,7 +249,7 @@ checkExpression mid (Let decls expr) = withScope $ do
idents'
<-
returnUnrefVars
when
(
not
$
null
idents'
)
$
foldM'
genWarning'
$
map
unrefVar
idents'
checkExpression
mid
(
Do
stmts
expr
)
=
withScope
$
do
foldM'
(
C
heck
M
ment
mid
)
stmts
foldM'
(
c
heck
State
ment
mid
)
stmts
checkExpression
mid
expr
idents'
<-
returnUnrefVars
when
(
not
$
null
idents'
)
$
foldM'
genWarning'
$
map
unrefVar
idents'
...
...
@@ -269,15 +269,15 @@ checkExpression mid (RecordUpdate fields expr) = do
checkExpression
_
_
=
checked
--
C
heck
M
ment
::
ModuleIdent
->
Statement
->
CheckM
()
C
heck
M
ment
mid
(
StmtExpr
_
expr
)
c
heck
State
ment
::
ModuleIdent
->
Statement
->
CheckM
()
c
heck
State
ment
mid
(
StmtExpr
_
expr
)
=
checkExpression
mid
expr
C
heck
M
ment
mid
(
StmtDecl
decls
)
=
do
c
heck
State
ment
mid
(
StmtDecl
decls
)
=
do
foldM'
checkLocalDecl
decls
foldM'
insertDecl
decls
foldM'
(
checkDecl
mid
)
decls
checkDeclOccurrences
decls
C
heck
M
ment
mid
(
StmtBind
_
cterm
expr
)
=
do
c
heck
State
ment
mid
(
StmtBind
_
cterm
expr
)
=
do
checkConstrTerm
mid
cterm
insertConstrTerm
False
cterm
checkExpression
mid
expr
...
...
@@ -372,7 +372,7 @@ checkDeclOccurrences decls = checkDO (mkIdent "") Map.empty decls
>>
checkDO
ident
env
decls'
)
(
Map
.
lookup
ident
env
))
else
checkDO
ident
env
decls'
checkDO
_
env
(
_
:
decls'
)
=
checkDO
(
mkIdent
""
)
env
decls'
checkDO
_
env
(
_
:
decls'
)
=
checkDO
(
mkIdent
""
)
env
decls'
-- check import declarations for multiply imported modules
...
...
@@ -556,7 +556,7 @@ genWarning pos msg
where
warnMsg
=
Message
(
Just
pos
)
msg
genWarning'
::
(
Position
,
String
)
->
CheckM
()
genWarning'
=
uncury
genWarning
genWarning'
=
uncur
r
y
genWarning
--
insertVar
::
Ident
->
CheckM
()
...
...
src/CompilerEnv.hs
View file @
90c3383e
...
...
@@ -5,8 +5,8 @@ import Curry.Base.Ident (ModuleIdent)
import
Env.Arity
import
Env.Eval
import
Env.Import
import
Env.Interfaces
import
Env.Label
import
Env.Module
import
Env.OpPrec
import
Env.TypeConstructors
import
Env.Value
...
...
@@ -17,8 +17,8 @@ data CompilerEnv = CompilerEnv
,
arityEnv
::
ArityEnv
,
evalAnnotEnv
::
EvalEnv
,
importEnv
::
ImportEnv
,
interfaceEnv
::
InterfaceEnv
,
labelEnv
::
LabelEnv
,
moduleEnv
::
ModuleEnv
,
opPrecEnv
::
PEnv
,
tyConsEnv
::
TCEnv
,
valueEnv
::
ValueEnv
...
...
@@ -30,8 +30,8 @@ initCompilerEnv mid = CompilerEnv
,
arityEnv
=
initAEnv
,
evalAnnotEnv
=
initEEnv
,
importEnv
=
initIEnv
,
interfaceEnv
=
initInterfaceEnv
,
labelEnv
=
initLEnv
,
moduleEnv
=
initMEnv
,
opPrecEnv
=
initPEnv
,
tyConsEnv
=
initTCEnv
,
valueEnv
=
initDCEnv
...
...
src/CurryBuilder.hs
View file @
90c3383e
...
...
@@ -8,7 +8,7 @@
module
CurryBuilder
(
buildCurry
,
smake
)
where
import
Control.Monad
(
liftM
)
import
Data.Maybe
(
catMaybes
,
fromMaybe
,
mapMaybe
)
import
Data.Maybe
(
catMaybes
,
mapMaybe
)
import
System.Time
(
ClockTime
)
import
Curry.Base.Ident
...
...
@@ -16,6 +16,7 @@ import Curry.Files.Filenames
import
Curry.Files.PathUtils
(
dropExtension
,
doesModuleExist
,
lookupCurryFile
,
getModuleModTime
,
tryGetModuleModTime
)
import
Base.ErrorMessages
(
errMissingFile
)
import
Base.Messages
(
status
,
abortWith
)
import
CompilerOpts
(
Options
(
..
),
TargetType
(
..
))
...
...
@@ -30,48 +31,45 @@ buildCurry :: Options -> FilePath -> IO ()
buildCurry
opts
file
=
do
mbFile
<-
lookupCurryFile
(
optImportPaths
opts
)
file
case
mbFile
of
Nothing
->
abortWith
[
m
issing
Modu
le
file
]
Nothing
->
abortWith
[
errM
issing
Fi
le
file
]
Just
f
->
do
(
mods
,
errs
)
<-
flatDeps
opts
f
if
null
errs
then
makeCurry
(
defaultToFlatCurry
opts
)
mods
f
else
abortWith
errs
where
missingModule
f
=
"Error: missing module
\"
"
++
f
++
"
\"
"
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
where
defaultToFlatCurry
opt
|
null
$
optTargetTypes
opt
=
opt
{
optTargetTypes
=
[
FlatCurry
]
}
|
otherwise
=
opt
makeCurry
::
Options
->
[(
ModuleIdent
,
Source
)]
->
FilePath
->
IO
()
makeCurry
opts
mods
targetFile
=
mapM_
(
compile
.
snd
)
mods
where
compile
(
Interface
_
)
=
return
()
compile
Unknown
=
return
()
compile
(
Source
file
deps
)
=
do
flatIntf
Exists
<-
doesModuleExist
$
flatIntName
file
interface
Exists
<-
doesModuleExist
$
flatIntName
file
if
dropExtension
targetFile
==
dropExtension
file
then
if
flatIntf
Exists
&&
not
(
optForce
opts
)
&&
null
(
optDumps
opts
)
then
smake
(
targetNames
file
)
(
targetF
ile
:
mapMaybe
flatInterface
deps
)
(
generateFile
file
)
(
skipFile
file
)
then
if
interface
Exists
&&
not
(
optForce
opts
)
&&
null
(
optDumps
opts
)
then
smake
(
targetNames
file
)
-- dest files
(
f
ile
:
mapMaybe
flatInterface
deps
)
-- dep files
(
generateFile
file
)
-- action on changed
(
skipFile
file
)
-- action on unchanged
else
generateFile
file
else
if
flatIntf
Exists
then
smake
[
flatName'
opts
file
]
(
file
:
mapMaybe
flatInterface
deps
)
(
compileFile
file
)
(
skipFile
file
)
else
if
interface
Exists
then
smake
[
flatName'
file
]
(
file
:
mapMaybe
flatInterface
deps
)
(
compileFile
file
)
(
skipFile
file
)
else
compileFile
file
compile
_
=
return
()
targetNames
fn
=
[
gen
fn
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
targetNames
fn
=
[
gen
fn
|
(
tgt
,
gen
)
<-
nameGens
,
tgt
`
elem
`
optTargetTypes
opts
]
where
nameGens
=
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
\
f
->
fromMaybe
(
sourceRepName
f
)
(
optOutput
opts
))
,
(
FlatXml
,
xmlName
)
[
(
FlatCurry
,
flatName
)
,
(
ExtendedFlatCurry
,
extFlatName
)
,
(
FlatXml
,
xmlName
)
,
(
AbstractCurry
,
acyName
)
,
(
UntypedAbstractCurry
,
uacyName
)
,
(
Parsed
,
sourceRepName
)
,
(
FlatXml
,
xmlName
)
]
flatInterface
mod1
=
case
lookup
mod1
mods
of
...
...
@@ -79,25 +77,19 @@ makeCurry opts mods targetFile = mapM_ (compile . snd) mods where
Just
(
Interface
file
)
->
Just
$
flatIntName
file
_
->
Nothing
flatName'
|
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
=
extFlatName
|
otherwise
=
flatName
compileFile
f
=
do
status
opts
$
"compiling "
++
f
compileModule
(
compOpts
True
)
f
skipFile
f
=
status
opts
$
"skipping "
++
f
compileModule
(
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
})
f
generateFile
f
=
do
status
opts
$
"generating "
++
head
(
targetNames
f
)
compileModule
(
compOpts
False
)
f
compileModule
opts
f
compOpts
isImport
|
isImport
=
opts
{
optTargetTypes
=
[
FlatCurry
],
optDumps
=
[]
}
|
otherwise
=
opts
flatName'
::
Options
->
FilePath
->
FilePath
flatName'
opts
|
ExtendedFlatCurry
`
elem
`
optTargetTypes
opts
=
extFlatName
|
otherwise
=
flatName
skipFile
f
=
status
opts
$
"skipping "
++
f
{- |A simple make function
...
...
src/CurryDeps.lhs
View file @
90c3383e
...
...
@@ -15,18 +15,19 @@ dependencies and to update programs composed of multiple modules.
\begin{verbatim}
>
module
CurryDeps
>
(
Source
(
..
),
deps
,
flatD
eps
,
flattenDeps
,
sourceDeps
,
moduleDeps
)
where
>
(
Source
(
..
),
flatDeps
,
d
eps
,
flattenDeps
,
sourceDeps
,
moduleDeps
)
where
>
import
Control.Monad
(
foldM
)
>
import
Data.List
(
intercalate
,
isSuffixOf
,
nub
)
>
import
Control.Monad
(
foldM
,
liftM
,
unless
)
>
import
Data.List
(
isSuffixOf
,
nub
)
>
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
toList
)
>
import
Curry.Base.Ident
>
import
Curry.Base.MessageMonad
>
import
Curry.Files.Filenames
>
import
Curry.Files.PathUtils
>
import
Curry.Syntax
hiding
(
Interface
(
..
)
)
>
import
Curry.Syntax
(
Module
(
..
),
Decl
(
..
),
parseHeader
)
>
import
Base.ErrorMessages
(
errCyclicImport
,
errWrongModule
)
>
import
Base.SCC
(
scc
)
>
import
CompilerOpts
(
Options
(
..
),
Extension
(
..
))
...
...
@@ -39,34 +40,14 @@ dependencies and to update programs composed of multiple modules.
>
type
SourceEnv
=
Map
.
Map
ModuleIdent
Source
>
flatDeps
::
Options
->
FilePath
->
IO
([(
ModuleIdent
,
Source
)],
[
String
])
>
flatDeps
opts
fn
=
do
>
mEnv
<-
deps
implicitPrelude
[]
libPaths
Map
.
empty
fn
>
return
$
flattenDeps
mEnv
>
where
>
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
opts
>
libPaths
=
optImportPaths
opts
>
deps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
>
->
IO
SourceEnv
>
deps
implicitPrelude
paths
libPaths
mEnv
fn
>
|
e
`
elem
`
sourceExts
>
=
sourceDeps
implicitPrelude
paths
libPaths
(
mkMIdent
[
r
])
mEnv
fn
>
|
e
==
icurryExt
>
=
return
Map
.
empty
>
|
e
`
elem
`
objectExts
>
=
targetDeps
implicitPrelude
paths
libPaths
mEnv
r
>
|
otherwise
>
=
targetDeps
implicitPrelude
paths
libPaths
mEnv
fn
>
where
r
=
dropExtension
fn
>
e
=
takeExtension
fn
>
targetDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
FilePath
>
->
IO
SourceEnv
>
targetDeps
implicitPrelude
paths
libraryPaths
mEnv
fn
=
>
lookupFile
[
""
]
sourceExts
fn
>>=
>
maybe
(
return
(
Map
.
insert
m
Unknown
mEnv
))
>
(
sourceDeps
implicitPrelude
paths
libraryPaths
m
mEnv
)
>
where
m
=
mkMIdent
[
fn
]
>
flatDeps
opts
fn
=
flattenDeps
`
liftM
`
deps
opts
[]
Map
.
empty
fn
>
deps
::
Options
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
IO
SourceEnv
>
deps
opts
paths
sEnv
fn
>
|
ext
==
icurryExt
=
return
Map
.
empty
>
|
ext
`
elem
`
sourceExts
=
sourceDeps
opts
paths
sEnv
fn
>
|
otherwise
=
targetDeps
opts
paths
sEnv
fn
>
where
ext
=
takeExtension
fn
\end{verbatim}
The following functions are used to lookup files related to a given
...
...
@@ -76,13 +57,36 @@ imported modules, the first is used to find source modules, whereas
the library path is used only for finding matching interface files. As
the compiler does not distinguish these paths, we actually check for
interface files in the source paths as well.
Note that the functions \texttt{buildScript} and \texttt{makeDepend}
already remove all directories that are included in the both search
paths from the library paths in order to avoid scanning such
directories more than twice.
\begin{verbatim}
>
sourceDeps
::
Options
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
IO
SourceEnv
>
sourceDeps
opts
paths
sEnv
fn
=
do
>
hdr
<-
(
ok
.
parseHeader
fn
)
`
liftM
`
readModule
fn
>
moduleDeps
opts
paths
sEnv
fn
hdr
>
targetDeps
::
Options
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
IO
SourceEnv
>
targetDeps
opts
paths
sEnv
fn
=
do
>
mFile
<-
lookupFile
[
""
]
sourceExts
fn
>
case
mFile
of
>
Nothing
->
return
$
Map
.
insert
(
mkMIdent
[
fn
])
Unknown
sEnv
>
Just
file
->
sourceDeps
opts
paths
sEnv
file
>
moduleDeps
::
Options
->
[
FilePath
]
->
SourceEnv
->
FilePath
->
Module
->
IO
SourceEnv
>
moduleDeps
opts
paths
sEnv
fn
(
Module
m
_
ds
)
=
case
Map
.
lookup
m
sEnv
of
>
Just
_
->
return
sEnv
>
Nothing
->
do
>
let
imps
=
imports
opts
m
ds
>
sEnv'
=
Map
.
insert
m
(
Source
fn
imps
)
sEnv
>
foldM
(
moduleIdentDeps
opts
paths
)
sEnv'
imps
>
-- |Retrieve the imported modules and add the import of the Prelude
>
-- according to the compiler options.
>
imports
::
Options
->
ModuleIdent
->
[
Decl
]
->
[
ModuleIdent
]
>
imports
opts
m
ds
=
nub
$
>
[
preludeMIdent
|
m
/=
preludeMIdent
&&
implicitPrelude
]
>
++
[
m'
|
ImportDecl
_
m'
_
_
_
<-
ds
]
>
where
implicitPrelude
=
NoImplicitPrelude
`
notElem
`
optExtensions
opts
\end{verbatim}
In order to compute the dependency graph, source files for each module
need to be looked up. When a source module is found, its header is
...
...
@@ -92,44 +96,31 @@ is added implicitly to the list of imported modules except for the
prelude itself. Any errors reported by the parser are ignored.
\begin{verbatim}
>
moduleDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
SourceEnv
->
ModuleIdent
>
->
IO
SourceEnv
>
moduleDeps
implicitPrelude
paths
libraryPaths
mEnv
m
=
>
case
Map
.
lookup
m
mEnv
of
>
Just
_
->
return
mEnv
>
Nothing
->
do
>
mbFn
<-
lookupModule
paths
libraryPaths
m
>
case
mbFn
of
>
Just
fn
>
|
icurryExt
`
isSuffixOf
`
fn
->
>
return
(
Map
.
insert
m
(
Interface
fn
)
mEnv
)
>
|
otherwise
->
sourceDeps
implicitPrelude
paths
libraryPaths
m
mEnv
fn
>
Nothing
->
return
(
Map
.
insert
m
Unknown
mEnv
)
>
sourceDeps
::
Bool
->
[
FilePath
]
->
[
FilePath
]
->
ModuleIdent
->
SourceEnv
>
->
FilePath
->
IO
SourceEnv
>
sourceDeps
implicitPrelude
paths
libraryPaths
m
mEnv
fn
=
do
>
s
<-
readModule
fn
>
case
fst
$
runMsg
$
parseHeader
fn
s
of
>
Right
(
Module
m'
_
ds
)
->
>
let
ms
=
imports
implicitPrelude
m'
ds
in
>
foldM
(
moduleDeps
implicitPrelude
paths
libraryPaths
)
>
(
Map
.
insert
m
(
Source
fn
ms
)
mEnv
)
ms
>
Left
_
->
return
(
Map
.
insert
m
(
Source
fn
[]
)
mEnv
)
>
-- |Retrieve the imported modules and add the import of the Prelude
>
-- according to the flag.
>
imports
::
Bool
->
ModuleIdent
->
[
Decl
]
->
[
ModuleIdent
]
>
imports
implicitPrelude
m
ds
=
nub
$
>
[
preludeMIdent
|
m
/=
preludeMIdent
&&
implicitPrelude
]
>
++
[
m'
|
ImportDecl
_
m'
_
_
_
<-
ds
]
>
moduleIdentDeps
::
Options
->
[
FilePath
]
->
SourceEnv
->
ModuleIdent
->
IO
SourceEnv
>
moduleIdentDeps
opts
paths
sEnv
m
=
case
Map
.
lookup
m
sEnv
of
>
Just
_
->
return
sEnv
>
Nothing
->
do
>
mFile
<-
lookupModule
paths
libraryPaths
m
>
case
mFile
of
>
Nothing
->
return
$
Map
.
insert
m
Unknown
sEnv
>
Just
fn
>
|
icurryExt
`
isSuffixOf
`
fn
->
return
$
Map
.
insert
m
(
Interface
fn
)
sEnv
>
|
otherwise
->
checkModuleHeader
fn
>
where
libraryPaths
=
optImportPaths
opts
>
checkModuleHeader
fn
=
do
>
hdr
@
(
Module
m'
_
_
)
<-
(
ok
.
parseHeader
fn
)
`
liftM
`
readModule
fn
>
unless
(
m
==
m'
)
$
error
$
errWrongModule
m
m'
>
moduleDeps
opts
paths
sEnv
fn
hdr
\end{verbatim}
If we want to compile the program instead of generating Makefile
dependencies the environment has to be sorted topologically. Note
that the dependency graph should not contain any cycles.
\begin{verbatim}
>
flattenDeps
::
SourceEnv
->
([(
ModuleIdent
,
Source
)],
[
String
])
>
flattenDeps
=
fdeps
.
sortDeps
where
>
flattenDeps
=
fdeps
.
sortDeps
>
where
>
sortDeps
::
SourceEnv
->
[[(
ModuleIdent
,
Source
)]]
>
sortDeps
=
scc
modules
imports'
.
Map
.
toList
>
...
...
@@ -145,13 +136,6 @@ that the dependency graph should not contain any cycles.
>
checkdep
[]
(
srcs
,
errs
)
=
(
srcs
,
errs
)
>
checkdep
[
src
]
(
srcs
,
errs
)
=
(
src
:
srcs
,
errs
)
>
checkdep
dep
(
srcs
,
errs
)
=
(
srcs
,
err
:
errs
)
>
where
err
=
cyclicError
(
map
fst
dep
)
>
cyclicError
::
[
ModuleIdent
]
->
String
>
cyclicError
ms
=
"Cylic import dependency between modules "
++
>
intercalate
", "
inits
++
" and "
++
lastm
where
>
(
inits
,
lastm
)
=
splitLast
$
map
moduleName
ms
>
splitLast
[]
=
error
"CurryDeps.splitLast: empty list"
>
splitLast
(
x
:
[]
)
=
(
[]
,
x
)
>
splitLast
(
x
:
y
:
ys
)
=
(
x
:
xs
,
z
)
>
where
(
xs
,
z
)
=
splitLast
(
y
:
ys
)
>
where
err
=
errCyclicImport
(
map
fst
dep
)
\end{verbatim}
src/Env/
Module
.hs
→
src/Env/
Interfaces
.hs
View file @
90c3383e
module
Env.
Module
where
module
Env.
Interfaces
where
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
lookup
)
import
Curry.Base.Ident
(
ModuleIdent
)
import
Curry.Syntax
(
IDecl
)
type
Modul
eEnv
=
Map
.
Map
ModuleIdent
[
IDecl
]
type
Interfac
eEnv
=
Map
.
Map
ModuleIdent
[
IDecl
]
lookup
Modul
e
::
ModuleIdent
->
Modul
eEnv
->
Maybe
[
IDecl
]
lookup
Modul
e
=
Map
.
lookup
lookup
Interfac
e
::
ModuleIdent
->
Interfac
eEnv
->
Maybe
[
IDecl
]
lookup
Interfac
e
=
Map
.
lookup
init
MEnv
::
Modul
eEnv
init
M
Env
=
Map
.
empty
init
InterfaceEnv
::
Interfac
eEnv
init
Interface
Env
=
Map
.
empty
src/Frontend.hs
View file @
90c3383e
...
...
@@ -8,29 +8,27 @@ module Frontend (parse, fullParse, typingParse) where
import
Data.Maybe
(
mapMaybe
)
import
qualified
Data.Map
as
Map
(
empty
)
import
Control.Monad.Writer