summaryrefslogtreecommitdiff
path: root/src/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler')
-rw-r--r--src/compiler/GF/Command/Commands.hs47
-rw-r--r--src/compiler/GF/Command/CommonCommands.hs6
-rw-r--r--src/compiler/GF/Command/TreeOperations.hs23
-rw-r--r--src/compiler/GF/Compile/Compute/Concrete.hs18
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs4
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs4
-rw-r--r--src/compiler/GF/CompileInParallel.hs18
-rw-r--r--src/compiler/GF/Data/BacktrackM.hs4
-rw-r--r--src/compiler/GF/Data/ErrM.hs4
-rw-r--r--src/compiler/GF/Grammar/Lexer.x4
-rw-r--r--src/compiler/GF/Infra/CheckM.hs4
-rw-r--r--src/compiler/GF/Infra/SIO.hs4
-rw-r--r--src/compiler/GF/Interactive.hs1
13 files changed, 85 insertions, 56 deletions
diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index f31a23083..876449136 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -22,6 +22,7 @@ import GF.Infra.SIO
import GF.Command.Abstract
import GF.Command.CommandInfo
import GF.Command.CommonCommands
+import qualified GF.Command.CommonCommands as Common
import GF.Text.Clitics
import GF.Quiz
@@ -166,14 +167,15 @@ pgfCommands = Map.fromList [
synopsis = "generate random trees in the current abstract syntax",
syntax = "gr [-cat=CAT] [-number=INT]",
examples = [
- mkEx "gr -- one tree in the startcat of the current grammar",
- mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP",
- mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha",
- mkEx "gr -probs=FILE -- generate with bias",
- mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))"
+ mkEx $ "gr -- one tree in the startcat of the current grammar, up to depth " ++ Common.default_depth_str,
+ mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP",
+ mkEx "gr -cat=NP -depth=2 -- one tree in the category NP, up to depth 2",
+ mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha",
+ mkEx "gr -probs=FILE -- generate with bias",
+ mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))"
],
explanation = unlines [
- "Generates a list of random trees, by default one tree.",
+ "Generates a list of random trees, by default one tree up to depth " ++ Common.default_depth_str ++ ".",
"If a tree argument is given, the command completes the Tree with values to",
"all metavariables in the tree. The generation can be biased by probabilities,",
"given in a file in the -probs flag."
@@ -182,13 +184,13 @@ pgfCommands = Map.fromList [
("cat","generation category"),
("lang","uses only functions that have linearizations in all these languages"),
("number","number of trees generated"),
- ("depth","the maximum generation depth"),
+ ("depth","the maximum generation depth (default: " ++ Common.default_depth_str ++ ")"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
pgf <- optProbs opts (optRestricted opts pgf)
gen <- newStdGen
- let dp = valIntOpts "depth" 4 opts
+ let dp = valIntOpts "depth" Common.default_depth opts
let ts = case mexp (toExprs arg) of
Just ex -> generateRandomFromDepth gen pgf ex (Just dp)
Nothing -> generateRandomDepth gen pgf (optType pgf opts) (Just dp)
@@ -199,25 +201,25 @@ pgfCommands = Map.fromList [
synopsis = "generates a list of trees, by default exhaustive",
explanation = unlines [
"Generates all trees of a given category. By default, ",
- "the depth is limited to 4, but this can be changed by a flag.",
+ "the depth is limited to " ++ Common.default_depth_str ++ ", but this can be changed by a flag.",
"If a Tree argument is given, the command completes the Tree with values",
"to all metavariables in the tree."
],
flags = [
("cat","the generation category"),
- ("depth","the maximum generation depth"),
+ ("depth","the maximum generation depth (default: " ++ Common.default_depth_str ++ ")"),
("lang","excludes functions that have no linearization in this language"),
("number","the number of trees generated")
],
examples = [
- mkEx "gt -- all trees in the startcat, to depth 4",
- mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP",
- mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
- mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
+ mkEx $ "gt -- all trees in the startcat, to depth " ++ Common.default_depth_str,
+ mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP",
+ mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
+ mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let pgfr = optRestricted opts pgf
- let dp = valIntOpts "depth" 4 opts
+ let dp = valIntOpts "depth" Common.default_depth opts
let ts = case toExprs arg of
[] -> generateAllDepth pgfr (optType pgf opts) (Just dp)
es -> concat [generateFromDepth pgfr e (Just dp) | e <- es]
@@ -428,7 +430,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,
@@ -546,7 +549,7 @@ pgfCommands = Map.fromList [
"which is processed by dot (graphviz) and displayed by the program indicated",
"by the view flag. The target format is png, unless overridden by the",
"flag -format. Results from multiple trees are combined to pdf with convert (ImageMagick).",
- "See also 'vp -showdep' for another visualization of dependencies."
+ "See also 'vp -showdep' for another visualization of dependencies."
],
exec = getEnv $ \ opts arg (Env pgf mos) -> do
let absname = abstractName pgf
@@ -759,7 +762,7 @@ pgfCommands = Map.fromList [
[] -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]
where
- dp = valIntOpts "depth" 4 opts
+ dp = valIntOpts "depth" Common.default_depth opts
fromParse opts = foldr (joinPiped . fromParse1 opts) void
@@ -799,9 +802,9 @@ pgfCommands = Map.fromList [
_ | isOpt "tabtreebank" opts ->
return $ concat $ intersperse "\t" $ (showExpr [] t) :
[s | lang <- optLangs pgf opts, s <- linear pgf opts lang t]
- _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t
+ _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t
_ -> [s | lang <- optLangs pgf opts, s<-linear pgf opts lang t]
- linChunks pgf opts t =
+ linChunks pgf opts t =
[(lang, unwords (intersperse "<+>" (map (unlines . linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts]
linear :: PGF -> [Option] -> CId -> Expr -> [String]
@@ -1005,13 +1008,13 @@ viewLatex view name grphs = do
restrictedSystem $ "pdflatex " ++ texfile
restrictedSystem $ view ++ " " ++ pdffile
return void
-
+
---- copied from VisualizeTree ; not sure about proper place AR Nov 2015
latexDoc :: [String] -> String
latexDoc body = unlines $
"\\batchmode"
: "\\documentclass{article}"
- : "\\usepackage[utf8]{inputenc}"
+ : "\\usepackage[utf8]{inputenc}"
: "\\begin{document}"
: spaces body
++ ["\\end{document}"]
diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs
index c685fc525..f1faa258e 100644
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -19,6 +19,12 @@ import Data.Char (isSpace)
import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
+-- store default generation depth in a variable and use everywhere
+default_depth :: Int
+default_depth = 5
+default_depth_str = show default_depth
+
+
extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
commonCommands :: (Monad m,MonadSIO m) => Map.Map String (CommandInfo m)
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)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 07:11:57 +0000