From 0581d6827ea2e4aac371eb05f3bf5508f3f40edc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= Date: Wed, 5 Aug 2020 17:29:10 +0200 Subject: [PATCH] Fix most build errors --- src/compiler/GF/Command/Commands.hs | 2 +- src/compiler/GF/Compile/GeneratePMCFG.hs | 3 +++ src/compiler/GF/Compile/Update.hs | 2 +- src/compiler/GF/CompileInParallel.hs | 3 +++ src/compiler/GF/CompileOne.hs | 2 +- src/compiler/GF/Data/Operations.hs | 4 ++-- src/compiler/GF/Grammar/Macros.hs | 2 +- src/compiler/GF/Infra/CheckM.hs | 3 +++ src/compiler/GF/Infra/Option.hs | 4 ++-- src/compiler/GF/Infra/SIO.hs | 3 +++ 10 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 72e57fcf5..718874d0c 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -44,7 +44,7 @@ pgfEnv pgf = Env pgf mos class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv -instance (Monad m,HasPGFEnv m) => TypeCheckArg m where +instance (Monad m,HasPGFEnv m,MonadFail m) => TypeCheckArg m where typeCheckArg e = (either (fail . render . ppTcError) (return . fst) . flip inferExpr e . pgf) =<< getPGFEnv diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 0558715c6..ac90852f3 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -196,6 +196,9 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar -> ([ProtoFCat],[Symbol]) -> Branch b} +instance MonadFail CnvMonad where + fail = bug + instance Applicative CnvMonad where pure = return (<*>) = ap diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 143a4f96f..93e281b6a 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -29,7 +29,7 @@ import Control.Monad import GF.Text.Pretty -- | combine a list of definitions into a balanced binary search tree -buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info) +buildAnyTree :: 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 68ac7aa4a..460869539 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -256,6 +256,9 @@ 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 + fail = CO . fail + instance ErrorMonad m => ErrorMonad (CollectOutput m) where raise e = CO (raise e) handle (CO m) h = CO $ handle m (unCO . h) diff --git a/src/compiler/GF/CompileOne.hs b/src/compiler/GF/CompileOne.hs index e873d6119..117a6b9a5 100644 --- a/src/compiler/GF/CompileOne.hs +++ b/src/compiler/GF/CompileOne.hs @@ -35,7 +35,7 @@ type OneOutput = (Maybe FullPath,CompiledModule) type CompiledModule = Module compileOne, reuseGFO, useTheSource :: - (Output m,ErrorMonad m,MonadIO m) => + (Output m,ErrorMonad m,MonadIO m, 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/Operations.hs b/src/compiler/GF/Data/Operations.hs index 4daa9c5d8..a9fedcaff 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -88,10 +88,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, Monad m) => Maybe a -> Maybe a -> m (Maybe a) +unifyMaybe :: (Eq a, MonadFail m) => Maybe a -> Maybe a -> m (Maybe a) unifyMaybe = unifyMaybeBy id -unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a) +unifyMaybeBy :: (Eq b, 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/Macros.hs b/src/compiler/GF/Grammar/Macros.hs index 4c92fae8c..56dc5cfb7 100644 --- a/src/compiler/GF/Grammar/Macros.hs +++ b/src/compiler/GF/Grammar/Macros.hs @@ -237,7 +237,7 @@ isPredefConstant t = case t of Q (mod,_) | mod == cPredef || mod == cPredefAbs -> True _ -> False -checkPredefError :: Monad m => Term -> m Term +checkPredefError :: 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 c5f9ba255..b0d9f1221 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -53,6 +53,9 @@ instance Monad Check where (ws,Success x) -> unCheck (g x) {-ctxt-} ws (ws,Fail msg) -> (ws,Fail msg) +instance 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 c4108cbe3..20e625114 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -547,7 +547,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 :: 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 +555,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 :: 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..2cb6d1ccd 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -58,6 +58,9 @@ 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 + fail = liftSIO . fail + instance Output SIO where ePutStr = lift0 . ePutStr ePutStrLn = lift0 . ePutStrLn