summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Command/Commands.hs3
-rw-r--r--src/compiler/GF/Command/Commands2.hs3
-rw-r--r--src/compiler/GF/Command/Interpreter.hs3
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs4
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs10
-rw-r--r--src/compiler/GF/Compile/Update.hs3
-rw-r--r--src/compiler/GF/CompileInParallel.hs5
-rw-r--r--src/compiler/GF/CompileOne.hs3
-rw-r--r--src/compiler/GF/Data/BacktrackM.hs8
-rw-r--r--src/compiler/GF/Data/ErrM.hs13
-rw-r--r--src/compiler/GF/Data/Operations.hs5
-rw-r--r--src/compiler/GF/Grammar/CanonicalJSON.hs16
-rw-r--r--src/compiler/GF/Grammar/Lexer.x6
-rw-r--r--src/compiler/GF/Grammar/Macros.hs3
-rw-r--r--src/compiler/GF/Infra/CheckM.hs4
-rw-r--r--src/compiler/GF/Infra/Option.hs5
-rw-r--r--src/compiler/GF/Infra/SIO.hs4
-rw-r--r--src/compiler/GF/Infra/UseIO.hs11
-rw-r--r--src/compiler/GF/Interactive.hs6
19 files changed, 98 insertions, 17 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 72e57fcf5..0e5c61404 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -34,6 +34,7 @@ import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Data.List (sort)
+import qualified Control.Monad.Fail as Fail
--import Debug.Trace
@@ -44,7 +45,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,Fail.MonadFail m) => TypeCheckArg m where
typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
. flip inferExpr e . pgf) =<< getPGFEnv
diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs
index 344b6b51d..100f877a9 100644
--- a/src/compiler/GF/Command/Commands2.hs
+++ b/src/compiler/GF/Command/Commands2.hs
@@ -18,6 +18,7 @@ import Data.Maybe
import qualified Data.Map as Map
import GF.Text.Pretty
import Control.Monad(mplus)
+import qualified Control.Monad.Fail as Fail
data PGFEnv = Env {pgf::Maybe PGF,concs::Map.Map ConcName Concr}
@@ -25,7 +26,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 (Monad 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/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs
index bcb15d238..1c38edf8b 100644
--- a/src/compiler/GF/Command/Interpreter.hs
+++ b/src/compiler/GF/Command/Interpreter.hs
@@ -11,6 +11,8 @@ import GF.Infra.UseIO(putStrLnE)
import Control.Monad(when)
import qualified Data.Map as Map
+import GF.Infra.UseIO (Output)
+import qualified Control.Monad.Fail as Fail
data CommandEnv m = CommandEnv {
commands :: Map.Map String (CommandInfo m),
@@ -22,6 +24,7 @@ data CommandEnv m = CommandEnv {
mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
--interpretCommandLine :: CommandEnv -> String -> SIO ()
+interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
interpretCommandLine env line =
case readCommandLine line of
Just [] -> return ()
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index 0558715c6..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,6 +197,9 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar
-> ([ProtoFCat],[Symbol])
-> Branch b}
+instance Fail.MonadFail CnvMonad where
+ fail = bug
+
instance Applicative CnvMonad where
pure = return
(<*>) = ap
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index 8fd6023b3..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
@@ -646,8 +648,16 @@ instance Monad TcM where
f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of
TcOk x ms msgs -> unTcM (g x) ms msgs
TcFail msgs -> TcFail msgs)
+
+#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
+
instance Applicative TcM where
pure = return
(<*>) = ap
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 143a4f96f..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 :: Monad 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 68ac7aa4a..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,6 +258,9 @@ instance Output m => Output (CollectOutput m) where
putStrLnE s = CO (return (putStrLnE s,()))
putStrE s = CO (return (putStrE s,()))
+instance Fail.MonadFail m => Fail.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..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) =>
+ (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 f5ae63997..14cbf90d2 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
@@ -69,6 +71,12 @@ instance Monad (BacktrackM s) where
return a = BM (\c s b -> c a s b)
BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
where unBM (BM m) = m
+
+#if !(MIN_VERSION_base(4,13,0))
+ 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 033c1efac..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
@@ -33,10 +35,19 @@ fromErr a = err (const a) id
instance Monad Err where
return = Ok
- fail = Bad
Ok a >>= f = f a
Bad s >>= f = Bad s
+#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
+
+
+
-- | added 2\/10\/2003 by PEB
instance Functor Err where
fmap f (Ok a) = Ok (f a)
diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs
index 4daa9c5d8..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, Monad 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, Monad 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/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs
index 8b3464674..0ec7f43e6 100644
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/src/compiler/GF/Grammar/CanonicalJSON.hs
@@ -6,6 +6,7 @@ import Text.JSON
import Control.Applicative ((<|>))
import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
+import Control.Monad (guard)
encodeJSON :: FilePath -> Grammar -> IO ()
@@ -126,10 +127,10 @@ instance JSON LinType where
-- records are encoded as records:
showJSON (RecordType rows) = showJSON rows
- readJSON o = do "Str" <- readJSON o; return StrType
- <|> do "Float" <- readJSON o; return FloatType
- <|> do "Int" <- readJSON o; return IntType
- <|> do ptype <- readJSON o; return (ParamType ptype)
+ readJSON o = StrType <$ parseString "Str" o
+ <|> FloatType <$ parseString "Float" o
+ <|> IntType <$ parseString "Int" o
+ <|> ParamType <$> readJSON o
<|> TableType <$> o!".tblarg" <*> o!".tblval"
<|> TupleType <$> o!".tuple"
<|> RecordType <$> readJSON o
@@ -186,7 +187,7 @@ instance JSON LinPattern where
-- and records as records:
showJSON (RecordPattern r) = showJSON r
- readJSON o = do "_" <- readJSON o; return WildPattern
+ readJSON o = do p <- parseString "_" o; return WildPattern
<|> do p <- readJSON o; return (ParamPattern (Param p []))
<|> ParamPattern <$> readJSON o
<|> RecordPattern <$> readJSON o
@@ -237,7 +238,7 @@ instance JSON VarId where
showJSON Anonymous = showJSON "_"
showJSON (VarId x) = showJSON x
- readJSON o = do "_" <- readJSON o; return Anonymous
+ readJSON o = do parseString "_" o; return Anonymous
<|> VarId <$> readJSON o
instance JSON QualId where
@@ -268,6 +269,9 @@ instance JSON FlagValue where
--------------------------------------------------------------------------------
-- ** Convenience functions
+parseString :: String -> JSValue -> Result ()
+parseString s o = guard . (== s) =<< readJSON o
+
(!) :: JSON a => JSValue -> String -> Result a
obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
readJSON
diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x
index d1550dd09..fe455c58a 100644
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -1,5 +1,6 @@
-- -*- haskell -*-
{
+{-# LANGUAGE CPP #-}
module GF.Grammar.Lexer
( Token(..), Posn(..)
, P, runP, runPartial, token, lexer, getPosn, failLoc
@@ -18,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
}
@@ -282,8 +284,12 @@ instance Monad P where
(P m) >>= k = P $ \ s -> case m s of
POk s a -> unP (k a) s
PFailed posn err -> PFailed posn err
+
+
+instance Fail.MonadFail P where
fail msg = P $ \(_,AI posn _ _) -> PFailed posn msg
+
runP :: P a -> BS.ByteString -> Either (Posn,String) a
runP p bs = snd <$> runP' p (Pn 1 0,bs)
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index 4c92fae8c..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 :: Monad 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 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
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index b68a1bc2f..c292fe944 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -38,6 +38,9 @@ import GF.Server(server)
#endif
import GF.Command.Messages(welcome)
+import GF.Infra.UseIO (Output)
+-- Provides an orphan instance of MonadFail for StateT in ghc versions < 8
+import Control.Monad.Trans.Instances ()
-- | Run the GF Shell in quiet mode (@gf -run@).
mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -131,7 +134,8 @@ execute1' s0 =
"dt":ws -> define_tree ws
-- ordinary commands
_ -> do env <- gets commandenv
- interpretCommandLine env s0
+ -- () env s0
+ -- interpretCommandLine env s0
continue
where
continue,stop :: ShellM Bool
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:26:29 +0000