diff --git a/CHANGELOG.md b/CHANGELOG.md index db7eec1f5d070f4c91ff34b07b29df894731fbcb..5cb30805383cf1878fff8a61c186f3b4dcaa0fb9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Base/Messages.hs b/src/Base/Messages.hs index 619fd204d666901b50dda2868ab2d6dc3f203755..322472401868a11794df7810b3f532677f09fc4d 100644 --- a/src/Base/Messages.hs +++ b/src/Base/Messages.hs @@ -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) diff --git a/src/Checks.hs b/src/Checks.hs index f86703d81bfdf2b6ecd8666ee6f21e33711a4c94..84d18378368383cbe64d667139c98ed3986660ff 100644 --- a/src/Checks.hs +++ b/src/Checks.hs @@ -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 diff --git a/src/CurryBuilder.hs b/src/CurryBuilder.hs index 64292b6f052eb1ca99b1553d99fcb875962894fa..b5b3476a49935676c0ea43852919171bd24eafd7 100644 --- a/src/CurryBuilder.hs +++ b/src/CurryBuilder.hs @@ -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 $ diff --git a/src/CurryDeps.hs b/src/CurryDeps.hs index 54f952d38b3aef68e0178b22adb24512c703074d..14c75aade300ce686f7534ca28553746215b5ead 100644 --- a/src/CurryDeps.hs +++ b/src/CurryDeps.hs @@ -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 diff --git a/src/Html/CurryHtml.hs b/src/Html/CurryHtml.hs index 115e7abd943c9f6a01ff8fe1c3c7fdce689fadb2..e7b079903513691ecb8235d2ba8e7e75b806ee96 100644 --- a/src/Html/CurryHtml.hs +++ b/src/Html/CurryHtml.hs @@ -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. diff --git a/src/Imports.hs b/src/Imports.hs index 03f7a211f1103184e87df8eb5eef56c5f88c45c9..981743b17ad09f34fbcbf3636f448f12832ee029 100644 --- a/src/Imports.hs +++ b/src/Imports.hs @@ -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 diff --git a/src/Interfaces.hs b/src/Interfaces.hs index 2785b9c0223a52e3543bcb2662087c13e8c2c6ff..d4edb3ec663832c294eddfc954ef4ad139695952 100644 --- a/src/Interfaces.hs +++ b/src/Interfaces.hs @@ -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' diff --git a/src/Modules.hs b/src/Modules.hs index 5da12420302a554402bc28d6cd2fd14d6592dc8c..aef7346e040d83ab6bae0a6d29c630b7fdd9f377 100644 --- a/src/Modules.hs +++ b/src/Modules.hs @@ -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') diff --git a/src/cymake.hs b/src/cymake.hs index 7200d3ac3e93dc62b823d03c9798d6280eba2c97..e4e4e7711df9f5abf4d390057f20a21270ab4577 100644 --- a/src/cymake.hs +++ b/src/cymake.hs @@ -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 ()