Commit 450f3ced authored by Jan Rasmus Tikovsky 's avatar Jan Rasmus Tikovsky

Replaced MessageM monad with CYT monads and moved CYT monads to curry-base

parent e3a3648e
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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 $
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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'
......
......@@ -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')
......
......@@ -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 ()
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment