Merge pull request #71 from anka-213/fix-newer-cabal

Fix support for newer stackage snapshots

4 files changed, 22 insertions, 2 deletions

diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs
index c5f9ba255..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,6 +54,9 @@ instance Monad Check where
                  (ws,Success x) -> unCheck (g x) {-ctxt-} ws
                  (ws,Fail msg)  -> (ws,Fail msg)
 
+instance Fail.MonadFail Check where
+  fail = raise
+
 instance Applicative Check where
   pure = return
   (<*>) = ap
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index afcd6f705..6b7ff0cad 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 
@@ -548,7 +549,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 :: Monad 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
@@ -556,7 +557,7 @@ onOff f def = OptArg g "[on,off]"
                         "off" -> return False
                         _     -> fail $ "Expected [on,off], got: " ++ show x
 
-readOutputFormat :: Monad 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 75c57601b..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,6 +59,9 @@ instance Monad SIO where
   return x = SIO (const (return x))
   SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
 
+instance Fail.MonadFail SIO where
+  fail = liftSIO . fail
+
 instance Output SIO where
   ePutStr = lift0 . ePutStr
   ePutStrLn = lift0 . ePutStrLn
diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs
index e27b6e075..4c5a26d32 100644
--- a/src/compiler/GF/Infra/UseIO.hs
+++ b/src/compiler/GF/Infra/UseIO.hs
@@ -159,6 +159,9 @@ instance ErrorMonad IO where
                                 then h (ioeGetErrorString e)
                                 else ioError e
 {-
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
 instance Functor IOE where fmap = liftM
 
 instance Applicative IOE where
@@ -170,7 +173,15 @@ instance  Monad IOE where
   IOE c >>= f = IOE $ do 
                   x <- c          -- Err a
                   appIOE $ err raise f x         -- f :: a -> IOE a
+
+ #if !(MIN_VERSION_base(4,13,0))
+  fail = raise
+ #endif
+
+instance Fail.MonadFail IOE where
   fail = raise
+
+
 -}
 
 -- | Print the error message and return a default value if the IO operation 'fail's