GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #175 from inariksit/new-ghc

Browse Source 
Changes to make it work with newer stack/GHC:

- unix library changed API in 2.8
- Monad of no return & Semigroup as a superclass of Monoid
- import Control.Monad (join, when, (<=<))
- fixed CI issues
This commit is contained in:
Inari Listenmaa
2025-08-02 18:59:07 +02:00
committed by GitHub
parent 981d6b9bdd 01c4f82e07
commit 65e85c5a3c
20 changed files with 86 additions and 59 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
.github/workflows/build-all-versions.yml vendored
View File

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

22
gf.cabal
View File

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

18
src/compiler/GF/Compile/Compute/Concrete.hs
View File

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

4
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

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

4
src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
View File

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

18
src/compiler/GF/CompileInParallel.hs
View File

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

4
src/compiler/GF/Data/BacktrackM.hs
View File

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

4
src/compiler/GF/Data/ErrM.hs
View File

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

4
src/compiler/GF/Grammar/Lexer.x
View File

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

4
src/compiler/GF/Infra/CheckM.hs
View File

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

4
src/compiler/GF/Infra/SIO.hs
View File

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

1
src/compiler/GF/Interactive.hs
View File

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

1
src/runtime/c/configure.ac
View File

@@ -30,6 +30,7 @@ AM_PROG_CC_C_O
-Wall\
-Wextra\
-Wno-missing-field-initializers\
-fpermissive\
-Wno-unused-parameter\
-Wno-unused-value"
fi]

2
src/runtime/haskell/Data/Binary/Builder.hs
View File

@@ -114,7 +114,7 @@ instance Semigroup Builder where
instance Monoid Builder where
mempty = empty
{-# INLINE mempty #-}
mappend = append
mappend = (<>)
{-# INLINE mappend #-}
------------------------------------------------------------------------

4
src/runtime/haskell/Data/Binary/Get.hs
View File

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

14
src/runtime/haskell/Data/Binary/Put.hs
View File

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

4
src/runtime/haskell/PGF/TypeCheck.hs
View File

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

5
src/server/CGIUtils.hs
View File

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

4
src/server/PGFService.hs
View File

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

7
stack-ghc9.6.6.yaml Normal file
View File

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