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