Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core into hleiss/master

.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.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.6.6"]
-        # 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: 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

doc/tutorial/gf-tutorial.t2t

@@ -1739,6 +1739,13 @@ A new module can **extend** an old one:
       Pizza : Kind ;
   }
 ```
+Note that the extended grammar doesn't inherit the start 
+category from the grammar it extends, so if you want to 
+generate sentences with this grammar, you'll have to either 
+add a startcat (e.g. ``flags startcat = Question ;``),
+or in the GF shell, specify the category to ``generate_random`` or ``geneate_trees``
+(e.g. ``gr -cat=Comment`` or ``gt -cat=Question``).
+
 Parallel to the abstract syntax, extensions can
 be built for concrete syntaxes:
 ```

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,
+    ghc-prim >= 0.5.0 && <= 0.10.0,
-    mtl >= 2.2.1 && < 2.3,
+    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,
+      terminfo >=0.4.0 && < 0.5
-      unix >= 2.7.2 && < 2.8
+
+    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,

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

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

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

src/compiler/GF/CompileInParallel.hs

@@ -61,11 +61,11 @@ parallelBatchCompile jobs opts rootfiles0 =
 
         usesPresent (_,paths) = take 1 libs==["present"]
           where
-            libs = [p|path<-paths,
+            libs = [p | path<-paths,
-                      let (d,p0) = splitAt n path
+                        let (d,p0) = splitAt n path
-                          p = dropSlash p0,
+                            p = dropSlash p0,
-                      d==lib_dir,p `elem` all_modes]
+                      d==lib_dir, p `elem` all_modes]
-            n = length lib_dir  
+            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 
+instance (Functor m,Monad m) => Applicative (CollectOutput m) where
-  pure = return
+  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

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
 

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

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

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

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

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)

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]

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 #-}
 
 ------------------------------------------------------------------------

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

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

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

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

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)

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