Discord
@@ -232,14 +227,10 @@ least one, it may help you to get a first idea of what GF is.
- We run the IRC channel #gf on the Libera network, where you are welcome to look for help with small questions or just start a general discussion.
- You can open a web chat
- or browse the channel logs.
-
-
- There is also a GF server on Discord.
+ We run the GF server on Discord, where you are welcome to look for help with small questions or just start a general discussion.
+
For bug reports and feature requests, please create an issue in the
GF Core or
@@ -254,6 +245,10 @@ least one, it may help you to get a first idea of what GF is.
News
+ - 2025-01-18
+ -
+ 9th GF Summer School, in Gothenburg, Sweden, 18 – 29 August 2025.
+
- 2023-01-24
-
8th GF Summer School, in Tampere, Finland, 14 – 25 August 2023.
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index a6c66594f..7f27e8a45 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -218,9 +218,9 @@ pgfCommands = Map.fromList [
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let pgfr = optRestricted opts pgf
let dp = valIntOpts "depth" 4 opts
- let ts = case mexp (toExprs arg) of
- Just ex -> generateFromDepth pgfr ex (Just dp)
- Nothing -> generateAllDepth pgfr (optType pgf opts) (Just dp)
+ let ts = case toExprs arg of
+ [] -> generateAllDepth pgfr (optType pgf opts) (Just dp)
+ es -> concat [generateFromDepth pgfr e (Just dp) | e <- es]
returnFromExprs $ take (optNumInf opts) ts
}),
("i", emptyCommandInfo {
@@ -428,7 +428,8 @@ pgfCommands = Map.fromList [
"are type checking and semantic computation."
],
examples = [
- mkEx "pt -compute (plus one two) -- compute value"
+ mkEx "pt -compute (plus one two) -- compute value",
+ mkEx ("p \"the 4 dogs\" | pt -transfer=digits2numeral | l -- \"the four dogs\" ")
],
exec = getEnv $ \ opts arg (Env pgf mos) ->
returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg,
diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs
index fc0e6616d..7497eb7e8 100644
--- a/src/compiler/GF/Command/TreeOperations.hs
+++ b/src/compiler/GF/Command/TreeOperations.hs
@@ -5,6 +5,8 @@ module GF.Command.TreeOperations (
) where
import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions)
+import PGF.Data(Expr(EApp,EFun))
+import PGF.TypeCheck(inferExpr)
import Data.List
type TreeOp = [Expr] -> [Expr]
@@ -16,15 +18,17 @@ allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))]
allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
Left $ map (compute pgf))),
+ ("transfer",("apply this transfer function to all maximal subtrees of suitable type",
+ Right $ \f -> map (transfer pgf f))), -- HL 12/24, modified from gf-3.3
("largest",("sort trees from largest to smallest, in number of nodes",
Left $ largest)),
- ("nub",("remove duplicate trees",
+ ("nub\t",("remove duplicate trees",
Left $ nub)),
("smallest",("sort trees from smallest to largest, in number of nodes",
Left $ smallest)),
("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest",
Left $ concatMap subtrees)),
- ("funs",("return all fun functions appearing in the tree, with duplications",
+ ("funs\t",("return all fun functions appearing in the tree, with duplications",
Left $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e]))
]
@@ -48,3 +52,18 @@ subtrees :: Expr -> [Expr]
subtrees t = t : case unApp t of
Just (f,ts) -> concatMap subtrees ts
_ -> [] -- don't go under abstractions
+
+-- Apply transfer function f:C -> D to all maximal subtrees s:C of tree e and replace
+-- these s by the values of f(s). This modifies the 'simple-minded transfer' of gf-3.3.
+-- If applied to strict subtrees s of e, better use with f:C -> C only. HL 12/2024
+
+transfer :: PGF -> CId -> Expr -> Expr
+transfer pgf f e = case inferExpr pgf (appf e) of
+ Left _err -> case e of
+ EApp g a -> EApp (transfer pgf f g) (transfer pgf f a)
+ _ -> e
+ Right _ty -> case (compute pgf (appf e)) of
+ v | v /= (appf e) -> v
+ _ -> e -- default case of f, or f has no computation rule
+ where
+ appf = EApp (EFun f)
diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs
index 47e2f5cde..2f4504ef5 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 8383f0624..74615dc98 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 ed3a20ce0..0e76c3205 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 ed498a690..11f806175 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 970de5c06..69bc2c29b 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 288c61919..133a49b73 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 b3d271ddd..248d091a1 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 a5ff7148a..1dd26dd5c 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 906f39345..7b5a7dac6 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 1970533d6..2edb5f3d8 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 2af669fe2..4e86e5251 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 8dc46f816..e22fa4a4c 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 a33c5c5a3..ec6309fae 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 189cf806f..05d23fba6 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/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index d015f18e0..42c0df14e 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -17,7 +17,8 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(..
MetaId,
-- helpers
- pMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens
+ pMeta,pArg,pLit,freshName,ppMeta,ppLit,ppParens,
+ freshBoundVars
) where
import PGF.CId
@@ -235,10 +236,11 @@ pLit = liftM LStr (RP.readS_to_P reads)
ppExpr :: Int -> [CId] -> Expr -> PP.Doc
ppExpr d scope (EAbs b x e) = let (bs,xs,e1) = getVars [] [] (EAbs b x e)
+ xs' = freshBoundVars scope xs
in ppParens (d > 1) (PP.char '\\' PP.<>
- PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs))) PP.<+>
+ PP.hsep (PP.punctuate PP.comma (reverse (List.zipWith ppBind bs xs'))) PP.<+>
PP.text "->" PP.<+>
- ppExpr 1 (xs++scope) e1)
+ ppExpr 1 (xs' ++ scope) e1)
where
getVars bs xs (EAbs b x e) = getVars (b:bs) ((freshName x xs):xs) e
getVars bs xs e = (bs,xs,e)
@@ -289,6 +291,15 @@ freshName x xs0 = loop 1 x
| elem y xs = loop (i+1) (mkCId (show x++show i))
| otherwise = y
+-- refresh new vars xs in scope if needed. AR 2024-03-01
+freshBoundVars :: [CId] -> [CId] -> [CId]
+freshBoundVars scope xs = foldr fresh [] xs
+ where
+ fresh x xs' = mkCId (freshName (showCId x) xs') : xs'
+ freshName s xs' =
+ if elem (mkCId s) (xs' ++ scope)
+ then freshName (s ++ "'") xs'
+ else s
-----------------------------------------------------
-- Computation
@@ -397,7 +408,7 @@ match sig f eqs as0 =
tryMatch (p ) (VMeta i envi vs ) env = VSusp i envi vs (\v -> tryMatch p v env)
tryMatch (p ) (VGen i vs ) env = VConst f as0
tryMatch (p ) (VSusp i envi vs k) env = VSusp i envi vs (\v -> tryMatch p (k v) env)
- tryMatch (p ) v@(VConst _ _ ) env = VConst f as0
+ tryMatch (p ) v@(VConst _ _ ) env = match sig f eqs as0
tryMatch (PApp f1 ps1) (VApp f2 vs2 ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env
tryMatch (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env
tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v env
diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index 5fdb186c1..a508f3dbc 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -81,7 +81,7 @@ linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
where
lp = lproductions cnc
- lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
+ lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (freshBoundVars (xs ++ ys) [x] ++ xs) e es --fresh: AR 2024
lin mb_cty n_fid e0 ys xs (EApp e1 e2) es = lin mb_cty n_fid e0 ys xs e1 (e2:es)
lin mb_cty n_fid e0 ys xs (EImplArg e) es = lin mb_cty n_fid e0 ys xs e es
lin mb_cty n_fid e0 ys xs (ETyped e _) es = lin mb_cty n_fid e0 ys xs e es
diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index c5cc44b4e..f02986fc0 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
@@ -147,9 +147,9 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
where
Scope gamma = scope
- y | cat == cidInt = return [(1.0,ELit (LInt 999), TTyp [] (DTyp [] cat []))]
- | cat == cidFloat = return [(1.0,ELit (LFlt 3.14), TTyp [] (DTyp [] cat []))]
- | cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))]
+ y | cat == cidInt = return [(0.1, ELit (LInt n), TTyp [] (DTyp [] cat [])) | n <- ints]
+ | cat == cidFloat = return [(0.1, ELit (LFlt d), TTyp [] (DTyp [] cat [])) | d <- floats]
+ | cat == cidString = return [(0.1, ELit (LStr s),TTyp [] (DTyp [] cat [])) | s <- strs]
| otherwise = TcM (\abstr k h ms ->
case Map.lookup cat (cats abstr) of
Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms
@@ -163,6 +163,11 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y)
where
s = sum [p | (p,_,_) <- gens]
+ -- random elements of predefined types: many instead of one AR 2025-01-17
+ ints = [1, 2, 3, 14, 42, 123, 999, 2025, 1000000, 1234567890]
+ floats = [0.0, 1.0, 3.14, 0.999, 0.5772156649, 2.71828, 6.62607015, 19.3, 0.0001, 1.60934]
+ strs = words "A B X Y b c x y foo bar"
+
emptyMetaStore :: MetaStore s
emptyMetaStore = IntMap.empty
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 32709bac0..4142332ac 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -651,6 +651,7 @@ app macro arg = text "\\" <> text macro <> text "{" <> arg <> text "}"
latexDoc :: Doc -> Doc
latexDoc body =
vcat [text "\\documentclass{article}",
+ text "\\usepackage[a4paper,margin=0.5in,landscape]{geometry}",
text "\\usepackage[utf8]{inputenc}",
text "\\begin{document}",
body,
diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs
index 3c5ce2274..0a04c3a6f 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 260c2e278..bcf3d32f2 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/src/www/robots.txt b/src/www/robots.txt
index 5b3ee3354..d559fc731 100644
--- a/src/www/robots.txt
+++ b/src/www/robots.txt
@@ -1,4 +1,5 @@
User-agent: *
Disallow: /grammars
Disallow: /robust
+Disallow: /wikidata
Disallow: /*.pgf
diff --git a/stack-ghc9.6.7.yaml b/stack-ghc9.6.7.yaml
new file mode 100644
index 000000000..f55acd828
--- /dev/null
+++ b/stack-ghc9.6.7.yaml
@@ -0,0 +1,20 @@
+resolver: ghc-9.6.7
+
+extra-deps:
+- multipart-0.2.1@sha256:559c04eed5218a9673e9fb6a225287fee1aeb38a45a0caf91a2598967bd75659,1150
+- cgi-3001.5.1.0@sha256:408e1f96ac6134965484c891b5fae35c7303fa841b09ce5baea52ddb078eef6b,3442
+- alex-3.5.3.0@sha256:f6fde8ff59e7e38f9e95eca8f5154fb611c9789d1d9538aa9745c6c3cd9495b4,4502
+- happy-2.1.6@sha256:1e963a137b650e766d1d0433e3404727fd64bebb850aa587702bfe199347f6da,5017
+- happy-lib-2.1.6@sha256:552a82e07605d6f8017f513be59b43219425aa0e4be71f9dddb2527f5accbce4,6081
+- httpd-shed-0.4.1.2@sha256:ab0fbd57acd32e0d5a5f7402dcc23192a1ffa142d86eeed051f59cf54a74ce38,1838
+- json-0.11@sha256:3afa37628415992fe648da6f002672f5a0119aa5d49022bf928d10a927c29318,3250
+- network-3.1.4.0@sha256:e152cdb03243afb52bbc740cfbe96905ca298a6f6342f0c47b3f2e227ff19def,5208
+- network-bsd-2.8.1.0@sha256:cc7867f81c6eb3f1924bbb1029757af6e3b67a3c224c1faa329be3ea70ad729c,3780
+- network-uri-2.6.4.2@sha256:6fffb57373962b5651a2db8b0af732098b3bf029a7ced76a9855615de2026588,3217
+- parallel-3.2.2.0@sha256:9d7b34ac537940f67732eca31d48a43bd78fb65a91baebddf63bee4fc3813d81,1961
+- random-1.2.1.3@sha256:117541ba0a177397a3333f94870f789ef050dca31b0688a19824b2bc401b8823,6237
+- splitmix-0.1.3.1@sha256:d0002f3fb16a2cc5ba8afd47a6657726386edccfe8853d310e3479fe3b45201b,6552
+- stringsearch-0.3.6.6@sha256:cd72bb03946006b18a6a374b7dc4a1c783a29df1889861604f95b1de1da98607,4258
+- syb-0.7.2.4@sha256:936d5a92084ad9d88c5a9dd2e622deab57ce48ce85be93e6273b3f8eb64c12ca,3872
+- th-compat-0.1.6@sha256:e83d97946f84fe492762ceb3b4753b4770c78b0b70e594078700baa91a5106c2,2885
+- utf8-string-1.0.2@sha256:79416292186feeaf1f60e49ac5a1ffae9bf1b120e040a74bf0e81ca7f1d31d3f,1538
diff --git a/stack.yaml b/stack.yaml
index 128b91f8a..05fda20a5 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,15 +1,23 @@
-# This default stack file is a copy of stack-ghc8.10.7.yaml
+# This default stack file is a copy of stack-ghc9.6.7.yaml
# But committing a symlink can be problematic on Windows, so it's a real copy.
# See: https://github.com/GrammaticalFramework/gf-core/pull/106
-resolver: lts-18.27 # ghc 8.10.7
+resolver: ghc-9.6.7
extra-deps:
-- network-2.6.3.6
-- httpd-shed-0.4.0.3
-
-# flags:
-# gf:
-# server: true
-# c-runtime: true
-# extra-lib-dirs:
-# - /usr/local/lib
+- multipart-0.2.1@sha256:559c04eed5218a9673e9fb6a225287fee1aeb38a45a0caf91a2598967bd75659,1150
+- cgi-3001.5.1.0@sha256:408e1f96ac6134965484c891b5fae35c7303fa841b09ce5baea52ddb078eef6b,3442
+- alex-3.5.3.0@sha256:f6fde8ff59e7e38f9e95eca8f5154fb611c9789d1d9538aa9745c6c3cd9495b4,4502
+- happy-2.1.6@sha256:1e963a137b650e766d1d0433e3404727fd64bebb850aa587702bfe199347f6da,5017
+- happy-lib-2.1.6@sha256:552a82e07605d6f8017f513be59b43219425aa0e4be71f9dddb2527f5accbce4,6081
+- httpd-shed-0.4.1.2@sha256:ab0fbd57acd32e0d5a5f7402dcc23192a1ffa142d86eeed051f59cf54a74ce38,1838
+- json-0.11@sha256:3afa37628415992fe648da6f002672f5a0119aa5d49022bf928d10a927c29318,3250
+- network-3.1.4.0@sha256:e152cdb03243afb52bbc740cfbe96905ca298a6f6342f0c47b3f2e227ff19def,5208
+- network-bsd-2.8.1.0@sha256:cc7867f81c6eb3f1924bbb1029757af6e3b67a3c224c1faa329be3ea70ad729c,3780
+- network-uri-2.6.4.2@sha256:6fffb57373962b5651a2db8b0af732098b3bf029a7ced76a9855615de2026588,3217
+- parallel-3.2.2.0@sha256:9d7b34ac537940f67732eca31d48a43bd78fb65a91baebddf63bee4fc3813d81,1961
+- random-1.2.1.3@sha256:117541ba0a177397a3333f94870f789ef050dca31b0688a19824b2bc401b8823,6237
+- splitmix-0.1.3.1@sha256:d0002f3fb16a2cc5ba8afd47a6657726386edccfe8853d310e3479fe3b45201b,6552
+- stringsearch-0.3.6.6@sha256:cd72bb03946006b18a6a374b7dc4a1c783a29df1889861604f95b1de1da98607,4258
+- syb-0.7.2.4@sha256:936d5a92084ad9d88c5a9dd2e622deab57ce48ce85be93e6273b3f8eb64c12ca,3872
+- th-compat-0.1.6@sha256:e83d97946f84fe492762ceb3b4753b4770c78b0b70e594078700baa91a5106c2,2885
+- utf8-string-1.0.2@sha256:79416292186feeaf1f60e49ac5a1ffae9bf1b120e040a74bf0e81ca7f1d31d3f,1538
diff --git a/testsuite/canonical/grammars/LexFoodsFin.gf b/testsuite/canonical/grammars/LexFoodsFin.gf
index 8b12f449f..bc79b740a 100644
--- a/testsuite/canonical/grammars/LexFoodsFin.gf
+++ b/testsuite/canonical/grammars/LexFoodsFin.gf
@@ -10,12 +10,12 @@ instance LexFoodsFin of LexFoods =
fish_N = mkN "kala" ;
fresh_A = mkA "tuore" ;
warm_A = mkA
- (mkN "l�mmin" "l�mpim�n" "l�mmint�" "l�mpim�n�" "l�mpim��n"
- "l�mpimin�" "l�mpimi�" "l�mpimien" "l�mpimiss�" "l�mpimiin"
+ (mkN "lämmin" "lämpimän" "lämmintä" "lämpimänä" "lämpimään"
+ "lämpiminä" "lämpimiä" "lämpimien" "lämpimissä" "lämpimiin"
)
- "l�mpim�mpi" "l�mpimin" ;
+ "lämpimämpi" "lämpimin" ;
italian_A = mkA "italialainen" ;
expensive_A = mkA "kallis" ;
delicious_A = mkA "herkullinen" ;
- boring_A = mkA "tyls�" ;
+ boring_A = mkA "tylsä" ;
}
diff --git a/testsuite/run.hs b/testsuite/run.hs
index f8e6bf49f..287665fd4 100644
--- a/testsuite/run.hs
+++ b/testsuite/run.hs
@@ -66,6 +66,7 @@ expectedFailures =
[ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected
, "testsuite/runtime/linearize/brackets.gfs" -- Missing "cannot linearize in the end"
, "testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs" -- Gives a different error than expected
+ , "testsuite/runtime/eval/eval.gfs"
]
-- | Produce HTML document with test results