summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn J. Camilleri <john@johnjcamilleri.com>2020-09-14 22:42:37 +0200
committerGitHub <noreply@github.com>2020-09-14 22:42:37 +0200
commit6c54e5b63cb563d780843a1970cba0718a5203f8 (patch)
treeed6777f6cb20f9212fa29ce68fac7e22745c707c
parentbca0691cb028fe33ae1b77e71752d4e937490ff1 (diff)
parent8bcdeedba01847325cc89378fed114bc0561bd4d (diff)
Merge pull request #71 from anka-213/fix-newer-cabal
Fix support for newer stackage snapshots
-rw-r--r--.github/workflows/build-all-versions.yml95
-rw-r--r--.github/workflows/build-debian-package.yml1
-rw-r--r--.gitignore1
-rw-r--r--Setup.hs1
-rw-r--r--gf.cabal6
-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
-rw-r--r--src/runtime/haskell/Data/Binary/Get.hs9
-rw-r--r--src/server/CGI.hs2
-rw-r--r--src/server/CGIUtils.hs9
-rw-r--r--src/tools/c/GFCC/ErrM.hs13
-rw-r--r--stack-ghc7.10.3.yaml11
-rw-r--r--stack-ghc8.6.5.yaml3
-rw-r--r--stack-ghc8.8.4.yaml9
-rw-r--r--stack.yaml8
-rw-r--r--testsuite/run.hs3
33 files changed, 255 insertions, 31 deletions
diff --git a/.github/workflows/build-all-versions.yml b/.github/workflows/build-all-versions.yml
new file mode 100644
index 000000000..52db74850
--- /dev/null
+++ b/.github/workflows/build-all-versions.yml
@@ -0,0 +1,95 @@
+# Based on the template here: https://kodimensional.dev/github-actions
+name: Build with stack and cabal
+
+# Trigger the workflow on push or pull request, but only for the master branch
+on:
+ pull_request:
+ push:
+ branches: [master]
+
+jobs:
+ cabal:
+ name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
+ runs-on: ${{ matrix.os }}
+ strategy:
+ matrix:
+ os: [ubuntu-latest, macOS-latest, windows-latest]
+ cabal: ["3.2"]
+ ghc:
+ - "8.6.5"
+ - "8.8.3"
+ - "8.10.1"
+ exclude:
+ - os: macOS-latest
+ ghc: 8.8.3
+ - os: macOS-latest
+ ghc: 8.6.5
+ - os: windows-latest
+ ghc: 8.8.3
+ - os: windows-latest
+ ghc: 8.6.5
+
+ steps:
+ - uses: actions/checkout@v2
+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+ - uses: actions/setup-haskell@v1.1.1
+ id: setup-haskell-cabal
+ name: Setup Haskell
+ with:
+ ghc-version: ${{ matrix.ghc }}
+ cabal-version: ${{ matrix.cabal }}
+
+ - name: Freeze
+ run: |
+ cabal freeze
+
+ - uses: actions/cache@v1
+ name: Cache ~/.cabal/store
+ with:
+ path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+ key: ${{ runner.os }}-${{ matrix.ghc }}
+ # key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+
+ - name: Build
+ run: |
+ cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
+ cabal build all
+
+ # - name: Test
+ # run: |
+ # cabal test all
+
+ stack:
+ name: stack / ghc ${{ matrix.ghc }}
+ runs-on: ubuntu-latest
+ strategy:
+ matrix:
+ stack: ["2.3.3"]
+ ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4"]
+ # ghc: ["8.8.3"]
+
+ steps:
+ - uses: actions/checkout@v2
+ if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+ - uses: actions/setup-haskell@v1.1
+ name: Setup Haskell Stack
+ with:
+ # ghc-version: ${{ matrix.ghc }}
+ stack-version: ${{ matrix.stack }}
+
+ - uses: actions/cache@v1
+ name: Cache ~/.stack
+ with:
+ path: ~/.stack
+ key: ${{ runner.os }}-${{ matrix.ghc }}-stack
+
+ - name: Build
+ run: |
+ stack build --system-ghc --stack-yaml stack-ghc${{ matrix.ghc }}.yaml
+ # stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
+
+ # - name: Test
+ # run: |
+ # stack test --system-ghc \ No newline at end of file
diff --git a/.github/workflows/build-debian-package.yml b/.github/workflows/build-debian-package.yml
index 17bbef66b..09719aaa8 100644
--- a/.github/workflows/build-debian-package.yml
+++ b/.github/workflows/build-debian-package.yml
@@ -18,6 +18,7 @@ jobs:
- name: Install build tools
run: |
+ sudo apt update
sudo apt install -y \
make \
dpkg-dev \
diff --git a/.gitignore b/.gitignore
index 0ee62cfb2..10968810e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -6,6 +6,7 @@
*.gfo
*.pgf
dist/
+dist-newstyle/
src/runtime/c/.libs/
src/runtime/c/Makefile
src/runtime/c/Makefile.in
diff --git a/Setup.hs b/Setup.hs
index 27524dbe5..1ee9cec92 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -19,7 +19,6 @@ main = defaultMainWithHooks simpleUserHooks
, preInst = gfPreInst
, postInst = gfPostInst
, postCopy = gfPostCopy
- , sDistHook = gfSDist
}
where
gfPreBuild args = gfPre args . buildDistPref
diff --git a/gf.cabal b/gf.cabal
index b6d6c7111..0076e7638 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -82,6 +82,10 @@ Library
pretty,
mtl,
exceptions,
+ fail,
+ -- For compatability with ghc < 8
+ -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
+ transformers-compat,
ghc-prim
hs-source-dirs: src/runtime/haskell
@@ -98,8 +102,6 @@ Library
--if impl(ghc>=7.8)
-- ghc-options: +RTS -A20M -RTS
ghc-prof-options: -fprof-auto
- if impl(ghc>=8.6)
- Default-extensions: NoMonadFailDesugaring
exposed-modules:
PGF
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
diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs
index 6e98434f5..01561d7d9 100644
--- a/src/runtime/haskell/Data/Binary/Get.hs
+++ b/src/runtime/haskell/Data/Binary/Get.hs
@@ -101,6 +101,10 @@ import GHC.Word
--import GHC.Int
#endif
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
+
-- | The parse state
data S = S {-# UNPACK #-} !B.ByteString -- current chunk
L.ByteString -- the rest of the input
@@ -126,6 +130,11 @@ instance Monad Get where
(a, s') -> unGet (k a) s')
{-# INLINE (>>=) #-}
+#if !(MIN_VERSION_base(4,13,0))
+ fail = failDesc
+#endif
+
+instance Fail.MonadFail Get where
fail = failDesc
instance MonadFix Get where
diff --git a/src/server/CGI.hs b/src/server/CGI.hs
index 1a77351e2..821f93b9c 100644
--- a/src/server/CGI.hs
+++ b/src/server/CGI.hs
@@ -4,7 +4,7 @@ import Network.CGI as C(
CGI,ContentType(..),Accept(..),Language(..),
getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
setHeader,output,outputFPS,outputError,
- handleErrors,catchCGI,throwCGI,
+ handleErrors,
liftIO)
import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs
index 04bb8f22c..3c5ce2274 100644
--- a/src/server/CGIUtils.hs
+++ b/src/server/CGIUtils.hs
@@ -15,11 +15,14 @@ import System.Posix
#endif
import CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
- getInput,catchCGI,throwCGI)
+ getInput)
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
import qualified Data.ByteString.Lazy as BS
+import Control.Monad.Catch (MonadThrow(throwM))
+import Network.CGI.Monad (catchCGI)
+import Control.Monad.Catch (MonadCatch(catch))
-- * Logging
@@ -53,11 +56,11 @@ instance Exception CGIError where
fromException (SomeException e) = cast e
throwCGIError :: Int -> String -> [String] -> CGI a
-throwCGIError c m t = throwCGI $ toException $ CGIError c m t
+throwCGIError c m t = throwM $ toException $ CGIError c m t
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors x =
- x `catchCGI` \e -> case fromException e of
+ x `catch` \e -> case fromException e of
Nothing -> throw e
Just (CGIError c m t) -> do setXO; outputError c m t
diff --git a/src/tools/c/GFCC/ErrM.hs b/src/tools/c/GFCC/ErrM.hs
index 820473ccd..78295d30e 100644
--- a/src/tools/c/GFCC/ErrM.hs
+++ b/src/tools/c/GFCC/ErrM.hs
@@ -4,6 +4,10 @@
-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
module GFCC.ErrM where
+-- Control.Monad.Fail import will become redundant in GHC 8.8+
+import qualified Control.Monad.Fail as Fail
+
+
-- the Error monad: like Maybe type with error msgs
data Err a = Ok a | Bad String
@@ -11,6 +15,13 @@ data Err a = Ok a | Bad String
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))
+ fail = Bad
+#endif
+
+instance Fail.MonadFail Err where
+ fail = Bad
+
diff --git a/stack-ghc7.10.3.yaml b/stack-ghc7.10.3.yaml
index a64e4e614..0761b54af 100644
--- a/stack-ghc7.10.3.yaml
+++ b/stack-ghc7.10.3.yaml
@@ -1 +1,12 @@
resolver: lts-6.35 # ghc 7.10.3
+
+extra-deps:
+- happy-1.19.9
+- alex-3.2.4
+- transformers-compat-0.6.5
+
+allow-newer: true
+
+flags:
+ transformers-compat:
+ four: true \ No newline at end of file
diff --git a/stack-ghc8.6.5.yaml b/stack-ghc8.6.5.yaml
index 0f98f8dfc..2e66c7bf6 100644
--- a/stack-ghc8.6.5.yaml
+++ b/stack-ghc8.6.5.yaml
@@ -1,5 +1,6 @@
-resolver: lts-14.3 # ghc 8.6.5
+resolver: lts-14.27 # ghc 8.6.5
extra-deps:
- network-2.6.3.6
- httpd-shed-0.4.0.3
+- cgi-3001.5.0.0
diff --git a/stack-ghc8.8.4.yaml b/stack-ghc8.8.4.yaml
new file mode 100644
index 000000000..a62db170b
--- /dev/null
+++ b/stack-ghc8.8.4.yaml
@@ -0,0 +1,9 @@
+resolver: lts-16.13 # ghc 8.8.4
+
+extra-deps:
+- network-2.6.3.6
+- httpd-shed-0.4.0.3
+- cgi-3001.5.0.0@sha256:3d1193a328d5f627a021a0ef3927c1ae41dd341e32dba612fed52d0e3a6df056,2990
+- json-0.10@sha256:d9fc6b07ce92b8894825a17d2cf14799856767eb30c8bf55962baa579207d799,3210
+- multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084
+
diff --git a/stack.yaml b/stack.yaml
index 59e36c4fa..f5d21085c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,9 +1,9 @@
-# This default stack file is a copy of stack-ghc8.2.2.yaml
+# This default stack file is a copy of stack-ghc8.6.5.yaml
# But committing a symlink is probably a bad idea, so it's a real copy
-resolver: lts-11.22 # ghc 8.2.2
+resolver: lts-14.27 # ghc 8.6.5
extra-deps:
-- cgi-3001.3.0.3
+- network-2.6.3.6
- httpd-shed-0.4.0.3
-- exceptions-0.10.2
+- cgi-3001.5.0.0 \ No newline at end of file
diff --git a/testsuite/run.hs b/testsuite/run.hs
index 71af1e403..6bf3c8158 100644
--- a/testsuite/run.hs
+++ b/testsuite/run.hs
@@ -1,6 +1,7 @@
import Data.List(partition)
import System.IO
import Distribution.Simple.BuildPaths(exeExtension)
+import Distribution.System ( buildPlatform )
import System.Process(readProcess)
import System.Directory(doesFileExist,getDirectoryContents)
import System.FilePath((</>),(<.>),takeExtension)
@@ -71,7 +72,7 @@ main =
-- Should consult the Cabal configuration!
run_gf = readProcess default_gf ["-run","-gf-lib-path="++gf_lib_path]
-default_gf = "dist/build/gf/gf"<.>exeExtension
+default_gf = "dist/build/gf/gf"<.>exeExtension buildPlatform
gf_lib_path = "dist/build/rgl"
-- | List files, excluding "." and ".."