Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
curry
curry-frontend
Commits
450f3ced
Commit
450f3ced
authored
Aug 11, 2014
by
Jan Rasmus Tikovsky
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Replaced MessageM monad with CYT monads and moved CYT monads to curry-base
parent
e3a3648e
Changes
10
Hide whitespace changes
Inline
Side-by-side
Showing
10 changed files
with
64 additions
and
70 deletions
+64
-70
CHANGELOG.md
CHANGELOG.md
+2
-0
src/Base/Messages.hs
src/Base/Messages.hs
+1
-13
src/Checks.hs
src/Checks.hs
+13
-12
src/CurryBuilder.hs
src/CurryBuilder.hs
+10
-9
src/CurryDeps.hs
src/CurryDeps.hs
+7
-7
src/Html/CurryHtml.hs
src/Html/CurryHtml.hs
+4
-5
src/Imports.hs
src/Imports.hs
+1
-0
src/Interfaces.hs
src/Interfaces.hs
+10
-9
src/Modules.hs
src/Modules.hs
+9
-13
src/cymake.hs
src/cymake.hs
+7
-2
No files found.
CHANGELOG.md
View file @
450f3ced
...
@@ -4,6 +4,8 @@ Change log for curry-frontend
...
@@ -4,6 +4,8 @@ Change log for curry-frontend
Under development
Under development
=================
=================
*
Replaced MessageM monad with CYT monads and moved CYT monads to curry-base
*
Implemented warnings for overlapping module aliases - fixes #14
*
Implemented warnings for overlapping module aliases - fixes #14
*
The check for overlapping rules has been completely refactored and
*
The check for overlapping rules has been completely refactored and
...
...
src/Base/Messages.hs
View file @
450f3ced
...
@@ -6,12 +6,11 @@ module Base.Messages
...
@@ -6,12 +6,11 @@ module Base.Messages
,
internalError
,
errorMessage
,
errorMessages
,
internalError
,
errorMessage
,
errorMessages
-- * creating messages
-- * creating messages
,
Message
,
message
,
posMessage
,
Message
,
message
,
posMessage
,
MonadIO
(
..
)
,
CYIO
,
CYT
,
left
,
right
,
runEitherCYIO
,
MonadIO
(
..
)
)
where
)
where
import
Control.Monad
(
unless
,
when
)
import
Control.Monad
(
unless
,
when
)
import
Control.Monad.IO.Class
(
MonadIO
(
..
))
import
Control.Monad.IO.Class
(
MonadIO
(
..
))
import
Control.Monad.Trans.Either
(
EitherT
,
left
,
right
,
runEitherT
)
import
Data.List
(
sort
)
import
Data.List
(
sort
)
import
System.IO
(
hFlush
,
hPutStrLn
,
stderr
,
stdout
)
import
System.IO
(
hFlush
,
hPutStrLn
,
stderr
,
stdout
)
import
System.Exit
(
exitFailure
)
import
System.Exit
(
exitFailure
)
...
@@ -20,17 +19,6 @@ import Curry.Base.Message ( Message, message, posMessage, ppMessage
...
@@ -20,17 +19,6 @@ import Curry.Base.Message ( Message, message, posMessage, ppMessage
,
ppMessages
,
ppWarning
,
ppError
)
,
ppMessages
,
ppWarning
,
ppError
)
import
CompilerOpts
(
Options
(
..
),
WarnOpts
(
..
),
Verbosity
(
..
))
import
CompilerOpts
(
Options
(
..
),
WarnOpts
(
..
),
Verbosity
(
..
))
type
CYT
m
a
=
EitherT
[
Message
]
m
a
type
CYIO
a
=
EitherT
[
Message
]
IO
a
runEitherCYIO
::
CYIO
a
->
IO
a
runEitherCYIO
act
=
do
res
<-
runEitherT
act
case
res
of
Left
errs
->
abortWithMessages
errs
Right
val
->
return
val
status
::
MonadIO
m
=>
Options
->
String
->
m
()
status
::
MonadIO
m
=>
Options
->
String
->
m
()
status
opts
msg
=
unless
(
optVerbosity
opts
<
VerbStatus
)
(
putMsg
msg
)
status
opts
msg
=
unless
(
optVerbosity
opts
<
VerbStatus
)
(
putMsg
msg
)
...
...
src/Checks.hs
View file @
450f3ced
...
@@ -21,6 +21,7 @@ import qualified Checks.SyntaxCheck as SC (syntaxCheck)
...
@@ -21,6 +21,7 @@ import qualified Checks.SyntaxCheck as SC (syntaxCheck)
import
qualified
Checks.TypeCheck
as
TC
(
typeCheck
)
import
qualified
Checks.TypeCheck
as
TC
(
typeCheck
)
import
qualified
Checks.WarnCheck
as
WC
(
warnCheck
)
import
qualified
Checks.WarnCheck
as
WC
(
warnCheck
)
import
Curry.Base.Monad
import
Curry.Syntax
(
Module
(
..
),
Interface
(
..
))
import
Curry.Syntax
(
Module
(
..
),
Interface
(
..
))
import
Base.Messages
import
Base.Messages
...
@@ -31,8 +32,8 @@ type Check m a = Options -> CompilerEnv -> a -> CYT m (CompilerEnv, a)
...
@@ -31,8 +32,8 @@ type Check m a = Options -> CompilerEnv -> a -> CYT m (CompilerEnv, a)
interfaceCheck
::
Monad
m
=>
Check
m
Interface
interfaceCheck
::
Monad
m
=>
Check
m
Interface
interfaceCheck
_
env
intf
interfaceCheck
_
env
intf
|
null
msgs
=
right
(
env
,
intf
)
|
null
msgs
=
ok
(
env
,
intf
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
msgs
=
IC
.
interfaceCheck
(
opPrecEnv
env
)
(
tyConsEnv
env
)
where
msgs
=
IC
.
interfaceCheck
(
opPrecEnv
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
intf
(
valueEnv
env
)
intf
...
@@ -43,8 +44,8 @@ interfaceCheck _ env intf
...
@@ -43,8 +44,8 @@ interfaceCheck _ env intf
-- * Environment: remains unchanged
-- * Environment: remains unchanged
kindCheck
::
Monad
m
=>
Check
m
Module
kindCheck
::
Monad
m
=>
Check
m
Module
kindCheck
_
env
(
Module
ps
m
es
is
ds
)
kindCheck
_
env
(
Module
ps
m
es
is
ds
)
|
null
msgs
=
right
(
env
,
Module
ps
m
es
is
ds'
)
|
null
msgs
=
ok
(
env
,
Module
ps
m
es
is
ds'
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
(
ds'
,
msgs
)
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
ds
where
(
ds'
,
msgs
)
=
KC
.
kindCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
ds
-- |Check for a correct syntax.
-- |Check for a correct syntax.
...
@@ -54,8 +55,8 @@ kindCheck _ env (Module ps m es is ds)
...
@@ -54,8 +55,8 @@ kindCheck _ env (Module ps m es is ds)
-- * Environment: remains unchanged
-- * Environment: remains unchanged
syntaxCheck
::
Monad
m
=>
Check
m
Module
syntaxCheck
::
Monad
m
=>
Check
m
Module
syntaxCheck
opts
env
mdl
syntaxCheck
opts
env
mdl
|
null
msgs
=
right
(
env
{
extensions
=
exts
},
mdl'
)
|
null
msgs
=
ok
(
env
{
extensions
=
exts
},
mdl'
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
((
mdl'
,
exts
),
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
where
((
mdl'
,
exts
),
msgs
)
=
SC
.
syntaxCheck
opts
(
valueEnv
env
)
(
tyConsEnv
env
)
mdl
(
tyConsEnv
env
)
mdl
...
@@ -66,8 +67,8 @@ syntaxCheck opts env mdl
...
@@ -66,8 +67,8 @@ syntaxCheck opts env mdl
-- * Environment: The operator precedence environment is updated
-- * Environment: The operator precedence environment is updated
precCheck
::
Monad
m
=>
Check
m
Module
precCheck
::
Monad
m
=>
Check
m
Module
precCheck
_
env
(
Module
ps
m
es
is
ds
)
precCheck
_
env
(
Module
ps
m
es
is
ds
)
|
null
msgs
=
right
(
env
{
opPrecEnv
=
pEnv'
},
Module
ps
m
es
is
ds'
)
|
null
msgs
=
ok
(
env
{
opPrecEnv
=
pEnv'
},
Module
ps
m
es
is
ds'
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
(
ds'
,
pEnv'
,
msgs
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
ds
where
(
ds'
,
pEnv'
,
msgs
)
=
PC
.
precCheck
(
moduleIdent
env
)
(
opPrecEnv
env
)
ds
-- |Apply the correct typing of the module.
-- |Apply the correct typing of the module.
...
@@ -75,16 +76,16 @@ precCheck _ env (Module ps m es is ds)
...
@@ -75,16 +76,16 @@ precCheck _ env (Module ps m es is ds)
-- environments are updated.
-- environments are updated.
typeCheck
::
Monad
m
=>
Check
m
Module
typeCheck
::
Monad
m
=>
Check
m
Module
typeCheck
_
env
mdl
@
(
Module
_
_
_
_
ds
)
typeCheck
_
env
mdl
@
(
Module
_
_
_
_
ds
)
|
null
msgs
=
right
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
},
mdl
)
|
null
msgs
=
ok
(
env
{
tyConsEnv
=
tcEnv'
,
valueEnv
=
tyEnv'
},
mdl
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
(
tcEnv'
,
tyEnv'
,
msgs
)
=
TC
.
typeCheck
(
moduleIdent
env
)
where
(
tcEnv'
,
tyEnv'
,
msgs
)
=
TC
.
typeCheck
(
moduleIdent
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
ds
(
tyConsEnv
env
)
(
valueEnv
env
)
ds
-- |Check the export specification
-- |Check the export specification
exportCheck
::
Monad
m
=>
Check
m
Module
exportCheck
::
Monad
m
=>
Check
m
Module
exportCheck
_
env
(
Module
ps
m
es
is
ds
)
exportCheck
_
env
(
Module
ps
m
es
is
ds
)
|
null
msgs
=
right
(
env
,
Module
ps
m
es'
is
ds
)
|
null
msgs
=
ok
(
env
,
Module
ps
m
es'
is
ds
)
|
otherwise
=
left
msgs
|
otherwise
=
failMessages
msgs
where
(
es'
,
msgs
)
=
EC
.
exportCheck
(
moduleIdent
env
)
(
aliasEnv
env
)
where
(
es'
,
msgs
)
=
EC
.
exportCheck
(
moduleIdent
env
)
(
aliasEnv
env
)
(
tyConsEnv
env
)
(
valueEnv
env
)
es
(
tyConsEnv
env
)
(
valueEnv
env
)
es
...
...
src/CurryBuilder.hs
View file @
450f3ced
...
@@ -21,6 +21,7 @@ import Data.Maybe (catMaybes, mapMaybe)
...
@@ -21,6 +21,7 @@ import Data.Maybe (catMaybes, mapMaybe)
import
System.FilePath
(
normalise
)
import
System.FilePath
(
normalise
)
import
Curry.Base.Ident
import
Curry.Base.Ident
import
Curry.Base.Monad
import
Curry.Base.Position
(
Position
)
import
Curry.Base.Position
(
Position
)
import
Curry.Base.Pretty
import
Curry.Base.Pretty
import
Curry.Files.Filenames
import
Curry.Files.Filenames
...
@@ -50,8 +51,8 @@ findCurry :: Options -> String -> CYIO FilePath
...
@@ -50,8 +51,8 @@ findCurry :: Options -> String -> CYIO FilePath
findCurry
opts
s
=
do
findCurry
opts
s
=
do
mbTarget
<-
findFile
`
orIfNotFound
`
findModule
mbTarget
<-
findFile
`
orIfNotFound
`
findModule
case
mbTarget
of
case
mbTarget
of
Nothing
->
left
[
complaint
]
Nothing
->
failMessages
[
complaint
]
Just
fn
->
right
fn
Just
fn
->
ok
fn
where
where
canBeFile
=
isCurryFilePath
s
canBeFile
=
isCurryFilePath
s
canBeModule
=
isValidModuleName
s
canBeModule
=
isValidModuleName
s
...
@@ -113,15 +114,15 @@ processPragmas opts0 ps = foldM processPragma opts0
...
@@ -113,15 +114,15 @@ processPragmas opts0 ps = foldM processPragma opts0
where
where
processPragma
opts
(
p
,
s
)
processPragma
opts
(
p
,
s
)
|
not
(
null
unknownFlags
)
|
not
(
null
unknownFlags
)
=
left
[
errUnknownOptions
p
unknownFlags
]
=
failMessages
[
errUnknownOptions
p
unknownFlags
]
|
optMode
opts
/=
optMode
opts'
|
optMode
opts
/=
optMode
opts'
=
left
[
errIllegalOption
p
"Cannot change mode"
]
=
failMessages
[
errIllegalOption
p
"Cannot change mode"
]
|
optLibraryPaths
opts
/=
optLibraryPaths
opts'
|
optLibraryPaths
opts
/=
optLibraryPaths
opts'
=
left
[
errIllegalOption
p
"Cannot change library path"
]
=
failMessages
[
errIllegalOption
p
"Cannot change library path"
]
|
optImportPaths
opts
/=
optImportPaths
opts'
|
optImportPaths
opts
/=
optImportPaths
opts'
=
left
[
errIllegalOption
p
"Cannot change import path"
]
=
failMessages
[
errIllegalOption
p
"Cannot change import path"
]
|
optTargetTypes
opts
/=
optTargetTypes
opts'
|
optTargetTypes
opts
/=
optTargetTypes
opts'
=
left
[
errIllegalOption
p
"Cannot change target type"
]
=
failMessages
[
errIllegalOption
p
"Cannot change target type"
]
|
otherwise
|
otherwise
=
return
opts'
=
return
opts'
where
where
...
@@ -196,8 +197,8 @@ smake dests deps actOutdated actUpToDate = do
...
@@ -196,8 +197,8 @@ smake dests deps actOutdated actUpToDate = do
cancelMissing
::
(
FilePath
->
IO
(
Maybe
a
))
->
FilePath
->
CYIO
a
cancelMissing
::
(
FilePath
->
IO
(
Maybe
a
))
->
FilePath
->
CYIO
a
cancelMissing
act
f
=
liftIO
(
act
f
)
>>=
\
res
->
case
res
of
cancelMissing
act
f
=
liftIO
(
act
f
)
>>=
\
res
->
case
res
of
Nothing
->
left
[
errModificationTime
f
]
Nothing
->
failMessages
[
errModificationTime
f
]
Just
val
->
right
val
Just
val
->
ok
val
errUnknownOptions
::
Position
->
[
String
]
->
Message
errUnknownOptions
::
Position
->
[
String
]
->
Message
errUnknownOptions
p
errs
=
posMessage
p
$
errUnknownOptions
p
errs
=
posMessage
p
$
...
...
src/CurryDeps.hs
View file @
450f3ced
...
@@ -24,6 +24,7 @@ import Data.List (isSuffixOf, nub)
...
@@ -24,6 +24,7 @@ import Data.List (isSuffixOf, nub)
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
toList
)
import
qualified
Data.Map
as
Map
(
Map
,
empty
,
insert
,
lookup
,
toList
)
import
Curry.Base.Ident
import
Curry.Base.Ident
import
Curry.Base.Monad
import
Curry.Base.Pretty
import
Curry.Base.Pretty
import
Curry.Files.Filenames
import
Curry.Files.Filenames
import
Curry.Files.PathUtils
import
Curry.Files.PathUtils
...
@@ -53,8 +54,8 @@ flatDeps :: Options -> FilePath -> CYIO [(ModuleIdent, Source)]
...
@@ -53,8 +54,8 @@ flatDeps :: Options -> FilePath -> CYIO [(ModuleIdent, Source)]
flatDeps
opts
fn
=
do
flatDeps
opts
fn
=
do
sEnv
<-
deps
opts
Map
.
empty
fn
sEnv
<-
deps
opts
Map
.
empty
fn
case
flattenDeps
sEnv
of
case
flattenDeps
sEnv
of
(
env
,
[]
)
->
right
env
(
env
,
[]
)
->
ok
env
(
_
,
errs
)
->
left
errs
(
_
,
errs
)
->
failMessages
errs
-- |Retrieve the dependencies of a source file as a 'SourceEnv'
-- |Retrieve the dependencies of a source file as a 'SourceEnv'
deps
::
Options
->
SourceEnv
->
FilePath
->
CYIO
SourceEnv
deps
::
Options
->
SourceEnv
->
FilePath
->
CYIO
SourceEnv
...
@@ -124,17 +125,16 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
...
@@ -124,17 +125,16 @@ moduleIdentDeps opts sEnv m = case Map.lookup m sEnv of
|
otherwise
->
do
|
otherwise
->
do
hdr
@
(
Module
_
m'
_
_
_
)
<-
readHeader
fn
hdr
@
(
Module
_
m'
_
_
_
)
<-
readHeader
fn
if
(
m
==
m'
)
then
moduleDeps
opts
sEnv
fn
hdr
if
(
m
==
m'
)
then
moduleDeps
opts
sEnv
fn
hdr
else
left
[
errWrongModule
m
m'
]
else
failMessages
[
errWrongModule
m
m'
]
readHeader
::
FilePath
->
CYIO
Module
readHeader
::
FilePath
->
CYIO
Module
readHeader
fn
=
do
readHeader
fn
=
do
mbFile
<-
liftIO
$
readModule
fn
mbFile
<-
liftIO
$
readModule
fn
case
mbFile
of
case
mbFile
of
Nothing
->
left
[
errMissingFile
fn
]
Nothing
->
failMessages
[
errMissingFile
fn
]
Just
src
->
do
Just
src
->
do
case
parseHeader
fn
src
of
hdr
<-
liftCYM
$
parseHeader
fn
src
Left
err
->
left
[
err
]
return
$
patchModuleId
fn
hdr
Right
hdr
->
return
$
patchModuleId
fn
hdr
-- If we want to compile the program instead of generating Makefile
-- If we want to compile the program instead of generating Makefile
-- dependencies, the environment has to be sorted topologically. Note
-- dependencies, the environment has to be sorted topologically. Note
...
...
src/Html/CurryHtml.hs
View file @
450f3ced
...
@@ -20,6 +20,7 @@ import Data.Maybe (fromMaybe, isJust)
...
@@ -20,6 +20,7 @@ import Data.Maybe (fromMaybe, isJust)
import
System.FilePath
((
</>
),
dropFileName
,
takeBaseName
)
import
System.FilePath
((
</>
),
dropFileName
,
takeBaseName
)
import
Curry.Base.Ident
(
QualIdent
(
..
),
unqualify
)
import
Curry.Base.Ident
(
QualIdent
(
..
),
unqualify
)
import
Curry.Base.Monad
import
Curry.Base.Pretty
(
text
)
import
Curry.Base.Pretty
(
text
)
import
Curry.Files.PathUtils
(
readModule
,
lookupCurryFile
)
import
Curry.Files.PathUtils
(
readModule
,
lookupCurryFile
)
import
Curry.Syntax
(
Module
,
lexSource
)
import
Curry.Syntax
(
Module
,
lexSource
)
...
@@ -52,11 +53,9 @@ filename2program opts f = do
...
@@ -52,11 +53,9 @@ filename2program opts f = do
case
mbModule
of
case
mbModule
of
Nothing
->
left
[
message
$
text
$
"Missing file: "
++
f
]
Nothing
->
left
[
message
$
text
$
"Missing file: "
++
f
]
Just
src
->
do
Just
src
->
do
case
lexSource
f
src
of
toks
<-
liftCYM
$
lexSource
f
src
Left
err
->
left
[
err
]
typed
<-
fullParse
opts
f
src
Right
toks
->
do
return
(
genProgram
typed
toks
)
typed
<-
fullParse
opts
f
src
return
(
genProgram
typed
toks
)
-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- |Return the syntax tree of the source program 'src' (type 'Module'; see
-- Module "CurrySyntax").after inferring the types of identifiers.
-- Module "CurrySyntax").after inferring the types of identifiers.
...
...
src/Imports.hs
View file @
450f3ced
...
@@ -23,6 +23,7 @@ import Data.Maybe
...
@@ -23,6 +23,7 @@ import Data.Maybe
import
qualified
Data.Set
as
Set
import
qualified
Data.Set
as
Set
import
Curry.Base.Ident
import
Curry.Base.Ident
import
Curry.Base.Monad
import
Curry.Base.Position
import
Curry.Base.Position
import
Curry.Base.Pretty
import
Curry.Base.Pretty
import
Curry.Syntax
import
Curry.Syntax
...
...
src/Interfaces.hs
View file @
450f3ced
...
@@ -29,6 +29,7 @@ import qualified Control.Monad.State as S (StateT, execStateT, gets, modify)
...
@@ -29,6 +29,7 @@ import qualified Control.Monad.State as S (StateT, execStateT, gets, modify)
import
qualified
Data.Map
as
M
(
insert
,
member
)
import
qualified
Data.Map
as
M
(
insert
,
member
)
import
Curry.Base.Ident
import
Curry.Base.Ident
import
Curry.Base.Monad
import
Curry.Base.Position
import
Curry.Base.Position
import
Curry.Base.Pretty
import
Curry.Base.Pretty
import
Curry.Files.PathUtils
import
Curry.Files.PathUtils
...
@@ -49,8 +50,8 @@ data LoaderState = LoaderState
...
@@ -49,8 +50,8 @@ data LoaderState = LoaderState
}
}
-- Report an error.
-- Report an error.
report
::
Message
->
IntfLoader
()
report
::
[
Message
]
->
IntfLoader
()
report
msg
=
S
.
modify
$
\
s
->
s
{
errs
=
msg
:
errs
s
}
report
msg
=
S
.
modify
$
\
s
->
s
{
errs
=
msg
++
errs
s
}
-- Check whether a module interface is already loaded.
-- Check whether a module interface is already loaded.
loaded
::
ModuleIdent
->
IntfLoader
Bool
loaded
::
ModuleIdent
->
IntfLoader
Bool
...
@@ -72,7 +73,7 @@ loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces
...
@@ -72,7 +73,7 @@ loadInterfaces :: [FilePath] -- ^ 'FilePath's to search in for interfaces
->
CYIO
InterfaceEnv
->
CYIO
InterfaceEnv
loadInterfaces
paths
(
Module
_
m
_
is
_
)
=
do
loadInterfaces
paths
(
Module
_
m
_
is
_
)
=
do
res
<-
liftIO
$
S
.
execStateT
load
(
LoaderState
initInterfaceEnv
paths
[]
)
res
<-
liftIO
$
S
.
execStateT
load
(
LoaderState
initInterfaceEnv
paths
[]
)
if
null
(
errs
res
)
then
right
(
iEnv
res
)
else
left
(
reverse
$
errs
res
)
if
null
(
errs
res
)
then
ok
(
iEnv
res
)
else
failMessages
(
reverse
$
errs
res
)
where
load
=
mapM_
(
loadInterface
[
m
])
[(
p
,
m'
)
|
ImportDecl
p
m'
_
_
_
<-
is
]
where
load
=
mapM_
(
loadInterface
[
m
])
[(
p
,
m'
)
|
ImportDecl
p
m'
_
_
_
<-
is
]
-- |Load an interface into the given environment.
-- |Load an interface into the given environment.
...
@@ -86,14 +87,14 @@ loadInterfaces paths (Module _ m _ is _) = do
...
@@ -86,14 +87,14 @@ loadInterfaces paths (Module _ m _ is _) = do
-- for in the import paths and compiled.
-- for in the import paths and compiled.
loadInterface
::
[
ModuleIdent
]
->
(
Position
,
ModuleIdent
)
->
IntfLoader
()
loadInterface
::
[
ModuleIdent
]
->
(
Position
,
ModuleIdent
)
->
IntfLoader
()
loadInterface
ctxt
imp
@
(
p
,
m
)
loadInterface
ctxt
imp
@
(
p
,
m
)
|
m
`
elem
`
ctxt
=
report
$
errCyclicImport
p
$
m
:
takeWhile
(
/=
m
)
ctxt
|
m
`
elem
`
ctxt
=
report
[
errCyclicImport
p
(
m
:
takeWhile
(
/=
m
)
ctxt
)]
|
otherwise
=
do
|
otherwise
=
do
isLoaded
<-
loaded
m
isLoaded
<-
loaded
m
unless
isLoaded
$
do
unless
isLoaded
$
do
paths
<-
searchPaths
paths
<-
searchPaths
mbIntf
<-
liftIO
$
lookupCurryInterface
paths
m
mbIntf
<-
liftIO
$
lookupCurryInterface
paths
m
case
mbIntf
of
case
mbIntf
of
Nothing
->
report
(
errInterfaceNotFound
p
m
)
Nothing
->
report
[
errInterfaceNotFound
p
m
]
Just
fn
->
compileInterface
ctxt
imp
fn
Just
fn
->
compileInterface
ctxt
imp
fn
-- |Compile an interface by recursively loading its dependencies.
-- |Compile an interface by recursively loading its dependencies.
...
@@ -105,15 +106,15 @@ compileInterface :: [ModuleIdent] -> (Position, ModuleIdent) -> FilePath
...
@@ -105,15 +106,15 @@ compileInterface :: [ModuleIdent] -> (Position, ModuleIdent) -> FilePath
compileInterface
ctxt
(
p
,
m
)
fn
=
do
compileInterface
ctxt
(
p
,
m
)
fn
=
do
mbSrc
<-
liftIO
$
readModule
fn
mbSrc
<-
liftIO
$
readModule
fn
case
mbSrc
of
case
mbSrc
of
Nothing
->
report
$
errInterfaceNotFound
p
m
Nothing
->
report
[
errInterfaceNotFound
p
m
]
Just
src
->
case
parseInterface
fn
src
of
Just
src
->
case
runCYM
(
parseInterface
fn
src
)
of
Left
err
->
report
err
Left
err
->
report
err
Right
intf
@
(
Interface
n
is
_
)
->
Right
intf
@
(
Interface
n
is
_
)
->
if
(
m
/=
n
)
if
(
m
/=
n
)
then
report
$
errWrongInterface
(
first
fn
)
m
n
then
report
[
errWrongInterface
(
first
fn
)
m
n
]
else
do
else
do
let
(
intf'
,
intfErrs
)
=
intfSyntaxCheck
intf
let
(
intf'
,
intfErrs
)
=
intfSyntaxCheck
intf
mapM_
report
intfErrs
mapM_
report
[
intfErrs
]
mapM_
(
loadInterface
(
m
:
ctxt
))
[
(
q
,
i
)
|
IImportDecl
q
i
<-
is
]
mapM_
(
loadInterface
(
m
:
ctxt
))
[
(
q
,
i
)
|
IImportDecl
q
i
<-
is
]
addInterface
m
intf'
addInterface
m
intf'
...
...
src/Modules.hs
View file @
450f3ced
...
@@ -32,6 +32,7 @@ import System.IO
...
@@ -32,6 +32,7 @@ import System.IO
import
System.Process
(
system
)
import
System.Process
(
system
)
import
Curry.Base.Ident
import
Curry.Base.Ident
import
Curry.Base.Monad
import
Curry.Base.Position
import
Curry.Base.Position
import
Curry.Base.Pretty
import
Curry.Base.Pretty
import
Curry.ExtendedFlat.InterfaceEquivalence
(
eqInterface
)
import
Curry.ExtendedFlat.InterfaceEquivalence
(
eqInterface
)
...
@@ -105,16 +106,11 @@ parseModule :: Options -> FilePath -> CYIO CS.Module
...
@@ -105,16 +106,11 @@ parseModule :: Options -> FilePath -> CYIO CS.Module
parseModule
opts
fn
=
do
parseModule
opts
fn
=
do
mbSrc
<-
liftIO
$
readModule
fn
mbSrc
<-
liftIO
$
readModule
fn
case
mbSrc
of
case
mbSrc
of
Nothing
->
left
[
message
$
text
$
"Missing file: "
++
fn
]
Nothing
->
failMessages
[
message
$
text
$
"Missing file: "
++
fn
]
Just
src
->
do
Just
src
->
do
case
CS
.
unlit
fn
src
of
ul
<-
liftCYM
$
CS
.
unlit
fn
src
Left
err
->
left
[
err
]
prepd
<-
preprocess
(
optPrepOpts
opts
)
fn
ul
Right
ul
->
do
liftCYM
$
CS
.
parseModule
fn
prepd
prepd
<-
preprocess
(
optPrepOpts
opts
)
fn
ul
-- parse module
case
CS
.
parseModule
fn
prepd
of
Left
err
->
left
[
err
]
Right
parsed
->
right
parsed
preprocess
::
PrepOpts
->
FilePath
->
String
->
CYIO
String
preprocess
::
PrepOpts
->
FilePath
->
String
->
CYIO
String
preprocess
opts
fn
src
preprocess
opts
fn
src
...
@@ -131,7 +127,7 @@ preprocess opts fn src
...
@@ -131,7 +127,7 @@ preprocess opts fn src
ExitFailure
x
->
return
$
Left
[
message
$
text
$
ExitFailure
x
->
return
$
Left
[
message
$
text
$
"Preprocessor exited with exit code "
++
show
x
]
"Preprocessor exited with exit code "
++
show
x
]
ExitSuccess
->
Right
`
liftM
`
readFile
outFn
ExitSuccess
->
Right
`
liftM
`
readFile
outFn
either
left
right
res
either
failMessages
ok
res
withTempFile
::
(
FilePath
->
Handle
->
IO
a
)
->
IO
a
withTempFile
::
(
FilePath
->
Handle
->
IO
a
)
->
IO
a
withTempFile
act
=
do
withTempFile
act
=
do
...
@@ -153,9 +149,9 @@ checkModuleId :: Monad m => FilePath -> CS.Module
...
@@ -153,9 +149,9 @@ checkModuleId :: Monad m => FilePath -> CS.Module
->
CYT
m
CS
.
Module
->
CYT
m
CS
.
Module
checkModuleId
fn
m
@
(
CS
.
Module
_
mid
_
_
_
)
checkModuleId
fn
m
@
(
CS
.
Module
_
mid
_
_
_
)
|
last
(
midQualifiers
mid
)
==
takeBaseName
fn
|
last
(
midQualifiers
mid
)
==
takeBaseName
fn
=
right
m
=
ok
m
|
otherwise
|
otherwise
=
left
[
errModuleFileMismatch
mid
]
=
failMessages
[
errModuleFileMismatch
mid
]
-- An implicit import of the prelude is added to the declarations of
-- An implicit import of the prelude is added to the declarations of
-- every module, except for the prelude itself, or when the import is disabled
-- every module, except for the prelude itself, or when the import is disabled
...
@@ -300,7 +296,7 @@ matchInterface :: FilePath -> CS.Interface -> IO Bool
...
@@ -300,7 +296,7 @@ matchInterface :: FilePath -> CS.Interface -> IO Bool
matchInterface
ifn
i
=
do
matchInterface
ifn
i
=
do
hdl
<-
openFile
ifn
ReadMode
hdl
<-
openFile
ifn
ReadMode
src
<-
hGetContents
hdl
src
<-
hGetContents
hdl
case
CS
.
parseInterface
ifn
src
of
case
runCYM
(
CS
.
parseInterface
ifn
src
)
of
Left
_
->
hClose
hdl
>>
return
False
Left
_
->
hClose
hdl
>>
return
False
Right
i'
->
return
(
i
`
intfEquiv
`
fixInterface
i'
)
Right
i'
->
return
(
i
`
intfEquiv
`
fixInterface
i'
)
...
...
src/cymake.hs
View file @
450f3ced
...
@@ -14,6 +14,8 @@
...
@@ -14,6 +14,8 @@
-}
-}
module
Main
(
main
)
where
module
Main
(
main
)
where
import
Curry.Base.Monad
(
runCYIO
)
import
Base.Messages
import
Base.Messages
import
Files.CymakePath
(
cymakeGreeting
,
cymakeVersion
)
import
Files.CymakePath
(
cymakeGreeting
,
cymakeVersion
)
import
Html.CurryHtml
(
source2html
)
import
Html.CurryHtml
(
source2html
)
...
@@ -33,9 +35,12 @@ cymake (prog, opts, files, errs)
...
@@ -33,9 +35,12 @@ cymake (prog, opts, files, errs)
|
mode
==
ModeNumericVersion
=
printNumericVersion
|
mode
==
ModeNumericVersion
=
printNumericVersion
|
not
$
null
errs
=
badUsage
prog
errs
|
not
$
null
errs
=
badUsage
prog
errs
|
null
files
=
badUsage
prog
[
"no input files"
]
|
null
files
=
badUsage
prog
[
"no input files"
]
|
mode
==
ModeHtml
=
runEitherCYIO
$
mapM_
(
source2html
opts
)
files
|
mode
==
ModeHtml
=
|
otherwise
=
runEitherCYIO
$
mapM_
(
buildCurry
opts
)
files
runCYIO
(
mapM_
(
source2html
opts
)
files
)
>>=
okOrAbort
|
otherwise
=
runCYIO
(
mapM_
(
buildCurry
opts
)
files
)
>>=
okOrAbort
where
mode
=
optMode
opts
where
mode
=
optMode
opts
okOrAbort
=
either
abortWithMessages
return
-- |Print the usage information of the command line tool
-- |Print the usage information of the command line tool
printUsage
::
String
->
IO
()
printUsage
::
String
->
IO
()
...
...
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