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

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

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)
 

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
 

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 $

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

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.

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

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'
 

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')
 

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 ()