diff --git a/.github/workflows/build-all-versions.yml b/.github/workflows/build-all-versions.yml index 2bd856b7ce..0f32228098 100644 --- a/.github/workflows/build-all-versions.yml +++ b/.github/workflows/build-all-versions.yml @@ -12,6 +12,7 @@ jobs: name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} runs-on: ${{ matrix.os }} strategy: + fail-fast: false matrix: os: [ubuntu-latest, macos-latest, windows-latest] cabal: ["latest"] @@ -19,21 +20,26 @@ jobs: - "8.6.5" - "8.8.3" - "8.10.7" + - "9.6.6" exclude: - os: macos-latest ghc: 8.8.3 - os: macos-latest ghc: 8.6.5 + - os: macos-latest + ghc: 8.10.7 - os: windows-latest ghc: 8.8.3 - os: windows-latest ghc: 8.6.5 + - os: windows-latest + ghc: 8.10.7 steps: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: haskell/actions/setup@v2 + - uses: haskell-actions/setup@v2 id: setup-haskell-cabal name: Setup Haskell with: @@ -44,7 +50,7 @@ jobs: run: | cabal freeze - - uses: actions/cache@v1 + - uses: actions/cache@v4 name: Cache ~/.cabal/store with: path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} @@ -66,14 +72,13 @@ jobs: strategy: matrix: stack: ["latest"] - ghc: ["7.10.3","8.0.2", "8.2.2", "8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2"] - # ghc: ["8.8.3"] + ghc: ["8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.6.6"] steps: - uses: actions/checkout@v2 if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' - - uses: haskell/actions/setup@v2 + - uses: haskell-actions/setup@v2 name: Setup Haskell Stack with: ghc-version: ${{ matrix.ghc }} @@ -85,7 +90,7 @@ jobs: - run: sed -i.bak 's/"C compiler link flags", "/&-no-pie /' /home/runner/.ghcup/ghc/7.10.3/lib/ghc-7.10.3/settings if: matrix.ghc == '7.10.3' - - uses: actions/cache@v1 + - uses: actions/cache@v4 name: Cache ~/.stack with: path: ~/.stack diff --git a/gf.cabal b/gf.cabal index 21093ae0be..ce0682d467 100644 --- a/gf.cabal +++ b/gf.cabal @@ -73,12 +73,12 @@ library build-depends: -- GHC 8.0.2 to GHC 8.10.4 array >= 0.5.1 && < 0.6, - base >= 4.9.1 && < 4.17, + base >= 4.9.1 && < 4.22, bytestring >= 0.10.8 && < 0.12, containers >= 0.5.7 && < 0.7, exceptions >= 0.8.3 && < 0.11, - ghc-prim >= 0.5.0 && < 0.9.0, - mtl >= 2.2.1 && < 2.3, + ghc-prim >= 0.5.0 && <= 0.10.0, + mtl >= 2.2.1 && <= 2.3.1, pretty >= 1.1.3 && < 1.2, random >= 1.1 && < 1.3, utf8-string >= 1.0.1.1 && < 1.1 @@ -155,10 +155,10 @@ library directory >= 1.3.0 && < 1.4, filepath >= 1.4.1 && < 1.5, haskeline >= 0.7.3 && < 0.9, - json >= 0.9.1 && < 0.11, + json >= 0.9.1 && <= 0.11, parallel >= 3.2.1.1 && < 3.3, process >= 1.4.3 && < 1.7, - time >= 1.6.0 && < 1.10 + time >= 1.6.0 && <= 1.12.2 hs-source-dirs: src/compiler exposed-modules: @@ -346,8 +346,14 @@ library Win32 >= 2.3.1.1 && < 2.7 else build-depends: - terminfo >=0.4.0 && < 0.5, - unix >= 2.7.2 && < 2.8 + terminfo >=0.4.0 && < 0.5 + + if impl(ghc >= 9.6.6) + build-depends: unix >= 2.8 + + else + build-depends: unix >= 2.7.2 && < 2.8 + if impl(ghc>=8.2) ghc-options: -fhide-source-paths @@ -392,7 +398,7 @@ test-suite gf-tests main-is: run.hs hs-source-dirs: testsuite build-depends: - base >= 4.9.1 && < 4.16, + base >= 4.9.1, Cabal >= 1.8, directory >= 1.3.0 && < 1.4, filepath >= 1.4.1 && < 1.5, diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs index 47e2f5cded..2f4504ef59 100644 --- a/src/compiler/GF/Compile/Compute/Concrete.hs +++ b/src/compiler/GF/Compile/Compute/Concrete.hs @@ -172,11 +172,11 @@ value env t0 = ImplArg t -> (VImplArg.) # value env t Table p res -> liftM2 VTblType # value env p <# value env res RecType rs -> do lovs <- mapPairsM (value env) rs - return $ \vs->VRecType $ mapSnd ($vs) lovs + return $ \vs->VRecType $ mapSnd ($ vs) lovs t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2) FV ts -> ((vfv .) # sequence) # mapM (value env) ts R as -> do lovs <- mapPairsM (value env.snd) as - return $ \ vs->VRec $ mapSnd ($vs) lovs + return $ \ vs->VRec $ mapSnd ($ vs) lovs T i cs -> valueTable env i cs V ty ts -> do pvs <- paramValues env ty ((VV ty pvs .) . sequence) # mapM (value env) ts @@ -376,10 +376,10 @@ valueTable env i cs = where dynamic cs' ty _ = cases cs' # value env ty - cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs)) + cases cs' vty vs = err keep ($ vs) (convertv cs' (vty vs)) where keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $ - VT wild (vty vs) (mapSnd ($vs) cs') + VT wild (vty vs) (mapSnd ($ vs) cs') wild = case i of TWild _ -> True; _ -> False @@ -392,7 +392,7 @@ valueTable env i cs = convert' cs' ((pty,vs),pvs) = do sts <- mapM (matchPattern cs') vs return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env) - (mapFst ($vs) sts) + (mapFst ($ vs) sts) valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p pvs <- linPattVars p' @@ -430,19 +430,19 @@ apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue apply' env t [] = value env t apply' env t vs = case t of - QC x -> return $ \ svs -> VCApp x (map ($svs) vs) + QC x -> return $ \ svs -> VCApp x (map ($ svs) vs) {- Q x@(m,f) | m==cPredef -> return $ let constr = --trace ("predef "++show x) . VApp x in \ svs -> maybe constr id (Map.lookup f predefs) - $ map ($svs) vs + $ map ($ svs) vs | otherwise -> do r <- resource env x - return $ \ svs -> vapply (gloc env) r (map ($svs) vs) + return $ \ svs -> vapply (gloc env) r (map ($ svs) vs) -} App t1 t2 -> apply' env t1 . (:vs) =<< value env t2 _ -> do fv <- value env t - return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs) + return $ \ svs -> vapply (gloc env) (fv svs) (map ($ svs) vs) vapply :: GLocation -> Value -> [Value] -> Value vapply loc v [] = v diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 8383f0624a..74615dc984 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -201,11 +201,11 @@ instance Fail.MonadFail CnvMonad where fail = bug instance Applicative CnvMonad where - pure = return + pure a = CM (\gr c s -> c a s) (<*>) = ap instance Monad CnvMonad where - return a = CM (\gr c s -> c a s) + return = pure CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s) instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index ed3a20ce03..0e76c3205e 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -644,7 +644,7 @@ data TcResult a newtype TcM a = TcM {unTcM :: MetaStore -> [Message] -> TcResult a} instance Monad TcM where - return x = TcM (\ms msgs -> TcOk x ms msgs) + return = pure f >>= g = TcM (\ms msgs -> case unTcM f ms msgs of TcOk x ms msgs -> unTcM (g x) ms msgs TcFail msgs -> TcFail msgs) @@ -659,7 +659,7 @@ instance Fail.MonadFail TcM where instance Applicative TcM where - pure = return + pure x = TcM (\ms msgs -> TcOk x ms msgs) (<*>) = ap instance Functor TcM where diff --git a/src/compiler/GF/CompileInParallel.hs b/src/compiler/GF/CompileInParallel.hs index ed498a6903..11f8061758 100644 --- a/src/compiler/GF/CompileInParallel.hs +++ b/src/compiler/GF/CompileInParallel.hs @@ -61,11 +61,11 @@ parallelBatchCompile jobs opts rootfiles0 = usesPresent (_,paths) = take 1 libs==["present"] where - libs = [p|path<-paths, - let (d,p0) = splitAt n path - p = dropSlash p0, - d==lib_dir,p `elem` all_modes] - n = length lib_dir + libs = [p | path<-paths, + let (d,p0) = splitAt n path + p = dropSlash p0, + d==lib_dir, p `elem` all_modes] + n = length lib_dir all_modes = ["alltenses","present"] @@ -175,7 +175,7 @@ batchCompile1 lib_dir (opts,filepaths) = " from being compiled." else return (maximum ts,(cnc,gr)) -splitEither es = ([x|Left x<-es],[y|Right y<-es]) +splitEither es = ([x | Left x<-es], [y | Right y<-es]) canonical path = liftIO $ D.canonicalizePath path `catch` const (return path) @@ -238,12 +238,12 @@ runCO (CO m) = do (o,x) <- m instance Functor m => Functor (CollectOutput m) where fmap f (CO m) = CO (fmap (fmap f) m) -instance (Functor m,Monad m) => Applicative (CollectOutput m) where - pure = return +instance (Functor m,Monad m) => Applicative (CollectOutput m) where + pure x = CO (return (return (),x)) (<*>) = ap instance Monad m => Monad (CollectOutput m) where - return x = CO (return (return (),x)) + return = pure CO m >>= f = CO $ do (o1,x) <- m let CO m2 = f x (o2,y) <- m2 diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 970de5c068..69bc2c29b1 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -64,11 +64,11 @@ finalStates :: BacktrackM s () -> s -> [s] finalStates bm = map fst . runBM bm instance Applicative (BacktrackM s) where - pure = return + pure a = BM (\c s b -> c a s b) (<*>) = ap instance Monad (BacktrackM s) where - return a = BM (\c s b -> c a s b) + return = pure BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) where unBM (BM m) = m diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs index 288c619198..133a49b73d 100644 --- a/src/compiler/GF/Data/ErrM.hs +++ b/src/compiler/GF/Data/ErrM.hs @@ -34,7 +34,7 @@ fromErr :: a -> Err a -> a fromErr a = err (const a) id instance Monad Err where - return = Ok + return = pure Ok a >>= f = f a Bad s >>= f = Bad s @@ -54,7 +54,7 @@ instance Functor Err where fmap f (Bad s) = Bad s instance Applicative Err where - pure = return + pure = Ok (<*>) = ap -- | added by KJ diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index b3d271dddb..248d091a16 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -283,11 +283,11 @@ instance Functor P where fmap = liftA instance Applicative P where - pure = return + pure a = a `seq` (P $ \s -> POk s a) (<*>) = ap instance Monad P where - return a = a `seq` (P $ \s -> POk s a) + return = pure (P m) >>= k = P $ \ s -> case m s of POk s a -> unP (k a) s PFailed posn err -> PFailed posn err diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index a5ff7148a5..1dd26dd5cd 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -48,7 +48,7 @@ newtype Check a instance Functor Check where fmap = liftM instance Monad Check where - return x = Check $ \{-ctxt-} ws -> (ws,Success x) + return = pure f >>= g = Check $ \{-ctxt-} ws -> case unCheck f {-ctxt-} ws of (ws,Success x) -> unCheck (g x) {-ctxt-} ws @@ -58,7 +58,7 @@ instance Fail.MonadFail Check where fail = raise instance Applicative Check where - pure = return + pure x = Check $ \{-ctxt-} ws -> (ws,Success x) (<*>) = ap instance ErrorMonad Check where diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 906f39345a..7b5a7dac67 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -52,11 +52,11 @@ newtype SIO a = SIO {unS::PutStr->IO a} instance Functor SIO where fmap = liftM instance Applicative SIO where - pure = return + pure x = SIO (const (pure x)) (<*>) = ap instance Monad SIO where - return x = SIO (const (return x)) + return = pure SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h instance Fail.MonadFail SIO where diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 1970533d6d..2edb5f3d88 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -32,6 +32,7 @@ import qualified Text.ParserCombinators.ReadP as RP import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) import Control.Exception(SomeException,fromException,evaluate,try) import Control.Monad.State hiding (void) +import Control.Monad (join, when, (<=<)) import qualified GF.System.Signal as IO(runInterruptibly) #ifdef SERVER_MODE import GF.Server(server) diff --git a/src/runtime/c/configure.ac b/src/runtime/c/configure.ac index 2af669fe25..4e86e52511 100644 --- a/src/runtime/c/configure.ac +++ b/src/runtime/c/configure.ac @@ -30,6 +30,7 @@ AM_PROG_CC_C_O -Wall\ -Wextra\ -Wno-missing-field-initializers\ + -fpermissive\ -Wno-unused-parameter\ -Wno-unused-value" fi] diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs index 8dc46f816a..e22fa4a4c1 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -114,7 +114,7 @@ instance Semigroup Builder where instance Monoid Builder where mempty = empty {-# INLINE mempty #-} - mappend = append + mappend = (<>) {-# INLINE mappend #-} ------------------------------------------------------------------------ diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs index a33c5c5a3a..ec6309fae0 100644 --- a/src/runtime/haskell/Data/Binary/Get.hs +++ b/src/runtime/haskell/Data/Binary/Get.hs @@ -127,11 +127,11 @@ instance Functor Get where {-# INLINE fmap #-} instance Applicative Get where - pure = return + pure a = Get (\s -> (a, s)) (<*>) = ap instance Monad Get where - return a = Get (\s -> (a, s)) + return = pure {-# INLINE return #-} m >>= k = Get (\s -> case unGet m s of diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/runtime/haskell/Data/Binary/Put.hs index 189cf806f8..05d23fba65 100644 --- a/src/runtime/haskell/Data/Binary/Put.hs +++ b/src/runtime/haskell/Data/Binary/Put.hs @@ -77,15 +77,20 @@ instance Functor PutM where {-# INLINE fmap #-} instance Applicative PutM where - pure = return + pure a = Put $ PairS a mempty m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') + m *> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `mappend` w') + {-# INLINE (*>) #-} -- Standard Writer monad, with aggressive inlining instance Monad PutM where - return a = Put $ PairS a mempty + return = pure {-# INLINE return #-} m >>= k = Put $ @@ -94,10 +99,7 @@ instance Monad PutM where in PairS b (w `mappend` w') {-# INLINE (>>=) #-} - m >> k = Put $ - let PairS _ w = unPut m - PairS b w' = unPut k - in PairS b (w `mappend` w') + (>>) = (*>) {-# INLINE (>>) #-} tell :: Builder -> Put diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 82bd47b7ad..f02986fc07 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -94,11 +94,11 @@ class Selector s where select :: CId -> Scope -> Maybe Int -> TcM s (Expr,TType) instance Applicative (TcM s) where - pure = return + pure x = TcM (\abstr k h -> k x) (<*>) = ap instance Monad (TcM s) where - return x = TcM (\abstr k h -> k x) + return = pure f >>= g = TcM (\abstr k h -> unTcM f abstr (\x -> unTcM (g x) abstr k h) h) instance Selector s => Alternative (TcM s) where diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs index 3c5ce22744..0a04c3a6f9 100644 --- a/src/server/CGIUtils.hs +++ b/src/server/CGIUtils.hs @@ -34,8 +34,13 @@ stderrToFile :: FilePath -> IO () stderrToFile file = do let mode = ownerReadMode<>ownerWriteMode<>groupReadMode<>otherReadMode (<>) = unionFileModes +#if MIN_VERSION_unix(2,8,0) + flags = defaultFileFlags { append = True, creat = Just mode } + fileFd <- openFd file WriteOnly flags +#else flags = defaultFileFlags { append = True } fileFd <- openFd file WriteOnly (Just mode) flags +#endif dupTo fileFd stdError return () #else diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 260c2e2780..bcf3d32f2a 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -448,7 +448,7 @@ pgfMain lcs@(alc,clc) path command tpgf@(t,pgf) = "linearizeTable" -> o =<< doLinearizeTabular pgf # tree % to "random" -> o =<< join (doRandom pgf # cat % depth % limit % to) "generate" -> o =<< doGenerate pgf # cat % depth % limit % to - "translate" -> o =<< doTranslate pgf # input % cat %to%limit%treeopts + "translate" -> o =<< doTranslate pgf # input % cat % to % limit % treeopts "translategroup" -> o =<< doTranslateGroup pgf # input % cat % to % limit "lookupmorpho" -> o =<< doLookupMorpho pgf # from1 % textInput "grammar" -> join $ doGrammar tpgf @@ -1092,7 +1092,7 @@ linearizeTabular pgf (tos,unlex) tree = [(to,lintab to (transfer to tree)) | to <- langs] where langs = if null tos then PGF.languages pgf else tos - lintab to t = [(p,map unlex (nub [t|(p',t)<-vs,p'==p]))|p<-ps] + lintab to t = [(p,map unlex (nub [t | (p',t)<-vs,p'==p])) | p<-ps] where ps = nub (map fst vs) vs = concat (PGF.tabularLinearizes pgf to t) diff --git a/stack-ghc9.6.6.yaml b/stack-ghc9.6.6.yaml new file mode 100644 index 0000000000..30da45c81b --- /dev/null +++ b/stack-ghc9.6.6.yaml @@ -0,0 +1,7 @@ +resolver: lts-22.29 # GHC-9.6.6 + +extra-deps: +- multipart-0.2.0@sha256:b8770e3ff6089be4dd089a8250894b31287cca671f3d258190a505f9351fa8a9,1084 +- cgi-3001.5.0.0@sha256:3d1193a328d5f627a021a0ef3927c1ae41dd341e32dba612fed52d0e3a6df056,2990 + +allow-newer: true