1
0
forked from GitHub/gf-core

Fix most build errors

This commit is contained in:
Andreas Källberg
2020-08-05 17:29:10 +02:00
parent b8812b54b2
commit 0581d6827e
10 changed files with 20 additions and 8 deletions

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

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

View File

@@ -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),

View File

@@ -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 ""

View File

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

View File

@@ -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

View File

@@ -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

View File

@@ -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