diff --git a/gf.cabal b/gf.cabal index a0fb968eb..014a2feea 100644 --- a/gf.cabal +++ b/gf.cabal @@ -82,6 +82,7 @@ Library pretty, mtl, exceptions, + fail, ghc-prim hs-source-dirs: src/runtime/haskell diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs index 41232fca8..6d326cdce 100644 --- a/src/compiler/GF/Command/Commands2.hs +++ b/src/compiler/GF/Command/Commands2.hs @@ -25,7 +25,7 @@ data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr} pgfEnv pgf = Env (Just pgf) (languages pgf) emptyPGFEnv = Env Nothing Map.empty -class (MonadFail m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv +class (Fail.MonadFail m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv instance (Monad m,HasPGFEnv m) => TypeCheckArg m where typeCheckArg e = do env <- getPGFEnv diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index ac90852f3..35c25cc0d 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -41,6 +41,7 @@ import Control.Monad import Control.Monad.Identity --import Control.Exception --import Debug.Trace(trace) +import qualified Control.Monad.Fail as Fail ---------------------------------------------------------------------- -- main conversion function @@ -196,7 +197,7 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar -> ([ProtoFCat],[Symbol]) -> Branch b} -instance MonadFail CnvMonad where +instance Fail.MonadFail CnvMonad where fail = bug instance Applicative CnvMonad where diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 3b9e62d04..b35aaf9ed 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module GF.Compile.TypeCheck.ConcreteNew( checkLType, inferLType ) where -- The code here is based on the paper: @@ -19,6 +20,7 @@ import GF.Text.Pretty import Data.List (nub, (\\), tails) import qualified Data.IntMap as IntMap import Data.Maybe(fromMaybe,isNothing) +import qualified Control.Monad.Fail as Fail checkLType :: GlobalEnv -> Term -> Type -> Check (Term, Type) checkLType ge t ty = runTcM $ do @@ -647,7 +649,12 @@ instance Monad TcM where TcOk x ms msgs -> unTcM (g x) ms msgs TcFail msgs -> TcFail msgs) -instance MonadFail TcM where +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail TcM where fail = tcError . pp diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 93e281b6a..4399405b8 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -27,9 +27,10 @@ import Data.List import qualified Data.Map as Map import Control.Monad import GF.Text.Pretty +import qualified Control.Monad.Fail as Fail -- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) +buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) buildAnyTree m = go Map.empty where go map [] = return map diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index 460869539..ed498a690 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -20,6 +20,8 @@ import GF.Infra.Ident(moduleNameS) import GF.Text.Pretty import GF.System.Console(TermColors(..),getTermColors) import qualified Data.ByteString.Lazy as BS +-- Control.Monad.Fail import will become redundant in GHC 8.8+ +import qualified Control.Monad.Fail as Fail -- | Compile the given grammar files and everything they depend on, -- like 'batchCompile'. This function compiles modules in parallel. @@ -256,7 +258,7 @@ instance Output m => Output (CollectOutput m) where putStrLnE s = CO (return (putStrLnE s,())) putStrE s = CO (return (putStrE s,())) -instance MonadFail m => MonadFail (CollectOutput m) where +instance Fail.MonadFail m => Fail.MonadFail (CollectOutput m) where fail = CO . fail instance ErrorMonad m => ErrorMonad (CollectOutput m) where diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index 117a6b9a5..48761671a 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -30,12 +30,13 @@ import qualified Data.Map as Map import GF.Text.Pretty(render,(<+>),($$)) --Doc, import GF.System.Console(TermColors(..),getTermColors) import Control.Monad((<=<)) +import qualified Control.Monad.Fail as Fail type OneOutput = (Maybe FullPath,CompiledModule) type CompiledModule = Module compileOne, reuseGFO, useTheSource :: - (Output m,ErrorMonad m,MonadIO m, MonadFail m) => + (Output m,ErrorMonad m,MonadIO m, Fail.MonadFail m) => Options -> Grammar -> FullPath -> m OneOutput -- | Compile a given source file (or just load a .gfo file), diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 87ea4dc5a..f947b838e 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -13,6 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE CPP #-} module GF.Data.BacktrackM ( -- * the backtracking state monad BacktrackM, @@ -32,6 +33,7 @@ import Data.List import Control.Applicative import Control.Monad import Control.Monad.State.Class +import qualified Control.Monad.Fail as Fail ---------------------------------------------------------------------- -- Combining endomorphisms and continuations @@ -70,7 +72,12 @@ instance Monad (BacktrackM s) where BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) where unBM (BM m) = m -instance MonadFail (BacktrackM s) where +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail (BacktrackM s) where fail _ = mzero instance Functor (BacktrackM s) where diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs index 5ea7f0734..288c61919 100644 --- a/src/compiler/GF/Data/ErrM.hs +++ b/src/compiler/GF/Data/ErrM.hs @@ -12,10 +12,12 @@ -- hack for BNFC generated files. AR 21/9/2003 ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} module GF.Data.ErrM where import Control.Monad (MonadPlus(..),ap) import Control.Applicative +import qualified Control.Monad.Fail as Fail -- | Like 'Maybe' type with error msgs data Err a = Ok a | Bad String @@ -36,7 +38,12 @@ instance Monad Err where Ok a >>= f = f a Bad s >>= f = Bad s -instance MonadFail Err where +#if !(MIN_VERSION_base(4,13,0)) + -- Monad(fail) will be removed in GHC 8.8+ + fail = Fail.fail +#endif + +instance Fail.MonadFail Err where fail = Bad diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index a9fedcaff..08fa15c3e 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -53,6 +53,7 @@ import Control.Monad (liftM,liftM2) --,ap import GF.Data.ErrM import GF.Data.Relation +import qualified Control.Monad.Fail as Fail infixr 5 +++ infixr 5 ++- @@ -88,10 +89,10 @@ checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where overloaded s = length (filter (==s) ss) > 1 -- | this is what happens when matching two values in the same module -unifyMaybe :: (Eq a, MonadFail m) => Maybe a -> Maybe a -> m (Maybe a) +unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a) unifyMaybe = unifyMaybeBy id -unifyMaybeBy :: (Eq b, MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a) +unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a) unifyMaybeBy f (Just p1) (Just p2) | f p1==f p2 = return (Just p1) | otherwise = fail "" diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index 57577ba16..fe455c58a 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -19,6 +19,7 @@ import qualified Data.Map as Map import Data.Word(Word8) import Data.Char(readLitChar) --import Debug.Trace(trace) +import qualified Control.Monad.Fail as Fail } @@ -285,7 +286,7 @@ instance Monad P where PFailed posn err -> PFailed posn err -instance MonadFail P where +instance Fail.MonadFail P where fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 56dc5cfb7..b088fe49c 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -32,6 +32,7 @@ import Control.Monad (liftM, liftM2, liftM3) import Data.List (sortBy,nub) import Data.Monoid import GF.Text.Pretty(render,(<+>),hsep,fsep) +import qualified Control.Monad.Fail as Fail -- ** Functions for constructing and analysing source code terms. @@ -237,7 +238,7 @@ isPredefConstant t = case t of Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True _ -> False -checkPredefError :: MonadFail m => Term -> m Term +checkPredefError :: Fail.MonadFail m => Term -> m Term checkPredefError t = case t of Error s -> fail ("Error: "++s) diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index b0d9f1221..c0234999a 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -32,6 +32,7 @@ import System.FilePath(makeRelative) import Control.Parallel.Strategies(parList,rseq,using) import Control.Monad(liftM,ap) import Control.Applicative(Applicative(..)) +import qualified Control.Monad.Fail as Fail type Message = Doc type Error = Message @@ -53,7 +54,7 @@ instance Monad Check where (ws,Success x) -> unCheck (g x) {-ctxt-} ws (ws,Fail msg) -> (ws,Fail msg) -instance MonadFail Check where +instance Fail.MonadFail Check where fail = raise instance Applicative Check where diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 20e625114..11a4dd8ec 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -44,6 +44,7 @@ import Data.Set (Set) import qualified Data.Set as Set import PGF.Internal(Literal(..)) +import qualified Control.Monad.Fail as Fail usageHeader :: String usageHeader = unlines @@ -547,7 +548,7 @@ lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs] lookupReadsPrec :: [(String,a)] -> Int -> ReadS a lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x] -onOff :: MonadFail m => (Bool -> m a) -> Bool -> ArgDescr (m a) +onOff :: Fail.MonadFail m => (Bool -> m a) -> Bool -> ArgDescr (m a) onOff f def = OptArg g "[on,off]" where g ma = maybe (return def) readOnOff ma >>= f readOnOff x = case map toLower x of @@ -555,7 +556,7 @@ onOff f def = OptArg g "[on,off]" "off" -> return False _ -> fail $ "Expected [on,off], got: " ++ show x -readOutputFormat :: MonadFail m => String -> m OutputFormat +readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat readOutputFormat s = maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 2cb6d1ccd..0ce431380 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -42,6 +42,7 @@ import qualified GF.Command.Importing as GF(importGrammar, importSource) #ifdef C_RUNTIME import qualified PGF2 #endif +import qualified Control.Monad.Fail as Fail -- * The SIO monad @@ -58,7 +59,7 @@ instance Monad SIO where return x = SIO (const (return x)) SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h -instance MonadFail SIO where +instance Fail.MonadFail SIO where fail = liftSIO . fail instance Output SIO where