summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/GF/API.hs20
-rw-r--r--src/GF/CF/CFIdent.hs9
-rw-r--r--src/GF/Canon/CMacros.hs54
-rw-r--r--src/GF/Compile/PGrammar.hs2
-rw-r--r--src/GF/Compile/ShellState.hs19
-rw-r--r--src/GF/Fudgets/CommandF.hs2
-rw-r--r--src/GF/Grammar/LookAbs.hs1
-rw-r--r--src/GF/Grammar/MMacros.hs7
-rw-r--r--src/GF/Grammar/TypeCheck.hs6
-rw-r--r--src/GF/Grammar/Values.hs8
-rw-r--r--src/GF/Infra/Option.hs12
-rw-r--r--src/GF/Shell.hs4
-rw-r--r--src/GF/Shell/Commands.hs84
-rw-r--r--src/GF/UseGrammar/Custom.hs37
-rw-r--r--src/GF/UseGrammar/Editing.hs7
-rw-r--r--src/GF/UseGrammar/Linear.hs24
-rw-r--r--src/GF/UseGrammar/Randomized.hs10
-rw-r--r--src/GF/UseGrammar/Session.hs24
-rw-r--r--src/Today.hs2
19 files changed, 220 insertions, 112 deletions
diff --git a/src/GF/API.hs b/src/GF/API.hs
index d2a60d24c..ad97fa821 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -138,11 +138,13 @@ randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree]
randomTreesIO opts gr n = do
gen <- myStdGen mx
t <- err (\s -> putStrLnFlush s >> return []) (return . singleton) $
- mkRandomTree gen mx g cat
+ mkRandomTree gen mx g catfun
ts <- if n==1 then return [] else randomTreesIO opts gr (n-1)
return $ t ++ ts
where
- cat = firstAbsCat opts gr
+ catfun = case getOptVal opts withFun of
+ Just fun -> Right $ (absId gr, I.identC fun)
+ _ -> Left $ firstAbsCat opts gr
g = grammar gr
mx = optIntOrN opts flagDepth 41
@@ -156,10 +158,18 @@ optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
-optLinearizeTree opts gr t
- | oElem showRecord opts = liftM prt $ linearizeNoMark g c t
- | otherwise = return $ linTree2string g c t
+optLinearizeTree opts gr t = case getOptVal opts markLin of
+ Just mk
+ | mk == markOptXML -> lin markXML t
+ | mk == markOptJava -> lin markXMLjgf t
+ | mk == markOptStruct -> lin markBracket t
+ | mk == markOptFocus -> lin markFocus t
+ | otherwise -> lin noMark t
+ _ -> lin noMark t
where
+ lin mk
+ | oElem showRecord opts = liftM prt . linearizeNoMark g c
+ | otherwise = return . linTree2string mk g c
g = grammar gr
c = cncId gr
diff --git a/src/GF/CF/CFIdent.hs b/src/GF/CF/CFIdent.hs
index d9c451adb..ab86b8bd4 100644
--- a/src/GF/CF/CFIdent.hs
+++ b/src/GF/CF/CFIdent.hs
@@ -107,6 +107,10 @@ idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
catVarCF :: CFCat
catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
+cat2CFCat :: (Ident,Ident) -> CFCat
+cat2CFCat = uncurry idents2CFCat
+
+
{- ----
uCFCat :: CFCat
uCFCat = cat2CFCat uCat
@@ -116,9 +120,8 @@ moduleOfCFCat :: CFCat -> Ident
moduleOfCFCat (CFCat (CIQ m _, _)) = m
-- the opposite direction
-cfCat2Cat :: CFCat -> CIdent
-cfCat2Cat (CFCat (s,_)) = s
-
+cfCat2Cat :: CFCat -> (Ident,Ident)
+cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
-- to construct CF tokens
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
index 8c1841fcc..49e9c71e4 100644
--- a/src/GF/Canon/CMacros.hs
+++ b/src/GF/Canon/CMacros.hs
@@ -3,6 +3,8 @@ module CMacros where
import AbsGFC
import GFC
import qualified Ident as A ---- no need to qualif? 21/9
+import qualified Values as V
+import qualified MMacros as M
import PrGrammar
import Str
@@ -13,21 +15,53 @@ import Monad
-- macros for concrete syntax in GFC that do not need lookup in a grammar
-markFocus :: Term -> Term
-markFocus = markSubterm "[*" "*]"
-
-markSubterm :: String -> String -> Term -> Term
-markSubterm beg end t = case t of
+-- how to mark subtrees, dep. on node, position, whether focus
+type Marker = V.TrNode -> [Int] -> Bool -> (String, String)
+
+markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
+markSubtree mk n is = markSubterm . mk n is
+
+-- if no marking is wanted, use the following
+noMark :: Marker
+noMark _ _ _ = ("","")
+
+-- for vanilla brackets, focus, and position, use
+markBracket :: Marker
+markBracket n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
+
+-- for focus only
+markFocus :: Marker
+markFocus n p b = if b then ("[*","*]") else ("","")
+
+-- for XML, use
+markXML :: Marker
+markXML n i b =
+ if b
+ then ("<focus" +++ p +++ c ++ ">", "</focus>")
+ else ("<subtree" +++ p +++ c ++ ">", "</subtree>")
+ where
+ c = "type=" ++ prt (M.valNode n)
+ p = "position=" ++ show i
+
+-- for XML in JGF 1, use
+markXMLjgf :: Marker
+markXMLjgf n p b =
+ if b
+ then ("<focus" +++ c ++ ">", "</focus>")
+ else ("","")
+ where
+ c = "type=" ++ prt (M.valNode n)
+
+-- the marking engine
+markSubterm :: (String,String) -> Term -> Term
+markSubterm (beg, end) t = case t of
R rs -> R $ map markField rs
T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
_ -> foldr1 C [tK beg, t, tK end] -- t : Str guaranteed?
where
- mark = markSubterm beg end
+ mark = markSubterm (beg, end)
markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
- isLinLabel (L (A.IC s)) = case s of ----
- 's':cs -> all isDigit cs
- _ -> False
-
+
tK :: String -> Term
tK = K . KS
diff --git a/src/GF/Compile/PGrammar.hs b/src/GF/Compile/PGrammar.hs
index 06d9fc72e..6237b6f25 100644
--- a/src/GF/Compile/PGrammar.hs
+++ b/src/GF/Compile/PGrammar.hs
@@ -43,12 +43,14 @@ string2formsAndTerm s = case s of
(x,_:y) -> (pTrms (tail x), pTrm y)
_ -> ([],pTrm s)
_ -> ([], pTrm s)
+-}
string2ident :: String -> Err Ident
string2ident s = return $ case s of
c:'_':i -> identV (readIntArg i,[c]) ---
_ -> zIdent s
+{-
-- reads the Haskell datatype
readGrammar :: String -> Err GrammarST
readGrammar s = case [x | (x,t) <- reads s, ("","") <- lex t] of
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index f24c3b87c..661e1bedd 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -3,8 +3,11 @@ module ShellState where
import Operations
import GFC
import AbsGFC
----import CMacros
+import Macros
+import MMacros
+
import Look
+import LookAbs
import qualified Modules as M
import qualified Grammar as G
import qualified PrGrammar as P
@@ -108,15 +111,12 @@ updateShellState opts sh (gr,(sgr,rts)) = do
notInrts f = notElem f $ map fst rts
cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all...
- let funs = [] ---- funRulesOf cgr
- let cats = [] ---- allCatsOf cgr
- let csi = [] ----
-{-
- [(c,(co,
+ let funs = funRulesOf cgr
+ let cats = allCatsOf cgr
+ let csi = [(c,(co,
[(fun,typ) | (fun,typ) <- funs, compatType tc typ],
funsOnTypeFs compatType funs tc))
- | (c,co) <- cats, let tc = cat2type c]
--}
+ | (c,co) <- cats, let tc = cat2val co c]
let deps = True ---- not $ null $ allDepCats cgr
let binds = [] ---- allCatsWithBind cgr
@@ -163,6 +163,9 @@ greatestAbstract gr = case allAbstracts gr of
[] -> Nothing
a -> return $ last a
+qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
+qualifTop gr (_,c) = (absId gr,c)
+
-- all concretes for a given abstract
allConcretes :: CanonGrammar -> Ident -> [Ident]
allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a]
diff --git a/src/GF/Fudgets/CommandF.hs b/src/GF/Fudgets/CommandF.hs
index 8bf791a61..9b193512f 100644
--- a/src/GF/Fudgets/CommandF.hs
+++ b/src/GF/Fudgets/CommandF.hs
@@ -14,7 +14,7 @@ import EventF
fudlogueEditF :: CEnv -> IO ()
fudlogueEditF env =
- fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env)
+ fudlogue $ gfSizeP $ shellF ("GF 2.0- Fudget Editor") (gfF env)
gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF
diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs
index 5e0994d46..66d6e4ca3 100644
--- a/src/GF/Grammar/LookAbs.hs
+++ b/src/GF/Grammar/LookAbs.hs
@@ -97,7 +97,6 @@ funsOnTypeFs compat fs val = [((fun,i),typ) |
(i,arg) <- zip [0..] (map snd args),
compat val arg]
-
-- this is needed at compile time
lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type
diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs
index 4078221dc..cea8af11a 100644
--- a/src/GF/Grammar/MMacros.hs
+++ b/src/GF/Grammar/MMacros.hs
@@ -231,6 +231,13 @@ fun2wrap oldvars ((fun,i),typ) exp = do
let vars = mkFreshVars (length cont) oldvars
return $ mkAbs vars $ if n==i then exp else mExp
+-- weak heuristics: sameness of value category
+compatType :: Val -> Type -> Bool
+compatType v t = errVal True $ do
+ cat1 <- val2cat v
+ cat2 <- valCat t
+ return $ cat1 == cat2
+
---
mkJustProd cont typ = mkProd (cont,typ,[])
diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs
index c97bdd362..a3487fdf7 100644
--- a/src/GF/Grammar/TypeCheck.hs
+++ b/src/GF/Grammar/TypeCheck.hs
@@ -229,3 +229,9 @@ editAsTermCommand gr c e = err (const []) singleton $ do
t <- annotate gr $ refreshMetas [] e
t' <- c $ tree2loc t
return $ tree2exp $ loc2tree t'
+
+exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree
+exp2termCommand gr f t = do
+ let exp = tree2exp t
+ exp2 <- f exp
+ annotate gr exp2
diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs
index 7b02d187a..9df2fc13e 100644
--- a/src/GF/Grammar/Values.hs
+++ b/src/GF/Grammar/Values.hs
@@ -50,3 +50,11 @@ tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
AtI s -> EInt s
bi' = map fst bi
ts' = map tree2exp ts
+
+loc2treeFocus :: Loc TrNode -> Tree
+loc2treeFocus (Loc (Tr (a,ts),p)) =
+ loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
+ where
+ (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True),
+ \(N (a,b,c,d,_)) -> N(a,b,c,d,False))
+
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index e81c9cd82..59e9f352a 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -20,6 +20,10 @@ oArg s = s -- value of option argument
oElem :: Option -> Options -> Bool
oElem o (Opts os) = elem o os
+eqOpt :: String -> Option -> Bool
+eqOpt s (Opt (o, [])) = s == o
+eqOpt s _ = False
+
type OptFun = String -> Option
getOptVal :: Options -> OptFun -> Maybe String
@@ -164,6 +168,7 @@ absView = iOpt "Abs"
useTokenizer = aOpt "lexer"
useUntokenizer = aOpt "unlexer"
useParser = aOpt "parser"
+withFun = aOpt "fun"
firstCat = aOpt "cat" -- used on command line
gStartCat = aOpt "startcat" -- used in grammar, to avoid clash w res word
useLanguage = aOpt "lang"
@@ -182,6 +187,13 @@ noDepTypes = aOpt "nodeptypes"
extractGr = aOpt "extract"
pathList = aOpt "path"
+markLin = aOpt "mark"
+markOptXML = oArg "xml"
+markOptJava = oArg "java"
+markOptStruct = oArg "struct"
+markOptFocus = oArg "focus"
+
+
-- refinement order
nextRefine = aOpt "nextrefine"
firstRefine = oArg "first"
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 6e4afe88f..0444a0a33 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -143,8 +143,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa
CImport file -> useIOE sa $ do
- st <- shellStateFromFiles opts st file
- ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a))
+ st1 <- shellStateFromFiles opts st file
+ ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a))
CEmptyState -> changeState reinitShellState sa
{-
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index 5c92c7bd6..f0bb8c4f4 100644
--- a/src/GF/Shell/Commands.hs
+++ b/src/GF/Shell/Commands.hs
@@ -9,6 +9,7 @@ import GFC
import qualified AbsGFC ---- Atom
import CMacros
import LookAbs
+import Values (loc2treeFocus)----
import GetTree
import API
@@ -27,7 +28,7 @@ import Unicode
import Option
import CF
------ import CFIdent (cat2CFCat, cfCat2Cat)
+import CFIdent (cat2CFCat, cfCat2Cat)
import Linear
import Randomized
import Editing
@@ -114,20 +115,19 @@ initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState)
execCommand env c s = case c of
-{- ----
--- these commands do need IO
- CCEnvImport file -> do
- gr <- optFile2grammar noOptions (maybeStateAbstract env) file
- let lan = getLangNameOpt noOptions file
- return (updateLanguage file (lan, getStateConcrete gr)
- (initWithAbstract (stateAbstract gr) env), s)
+-- these commands do need IO
+ CCEnvImport file -> useIOE (env,s) $ do
+ st <- shellStateFromFiles opts env file
+ return (st,s)
+{- ----
CCEnvEmptyAndImport file -> do
gr <- optFile2grammar noOptions Nothing file
let lan = getLangNameOpt noOptions file
return (updateLanguage file (lan, getStateConcrete gr)
(initWithAbstract (stateAbstract gr) emptyShellState), initSState)
+-}
CCEnvEmpty -> do
return (emptyShellState, initSState)
@@ -137,6 +137,7 @@ execCommand env c s = case c of
(msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
return (env', changeMsg msg s) ----
+{- ----
CCEnvOpenTerm file -> do
c <- readFileIf file
let (fs,t) = envAndTerm file c
@@ -159,10 +160,11 @@ execCommand env c s = case c of
state1 <- return $
refineByExps True gr (parseAny agrs cat t) $ changeState state0 s
return (env', state1)
-
- CCEnvOn name -> return (languageOn (language name) env,s)
- CCEnvOff name -> return (languageOff (language name) env,s)
-}
+
+---- CCEnvOn name -> return (languageOn (language name) env,s)
+---- CCEnvOff name -> return (languageOff (language name) env,s)
+
-- this command is improved by the use of IO
CRefineRandom -> do
g <- newStdGen
@@ -196,12 +198,10 @@ execECommand env c = case c of
CNewCat cat -> action2commandNext $ \x -> do
s' <- newCat cgr cat x
uniqueRefinements cgr s'
-{- ----
CNewTree s -> action2commandNext $ \x -> do
t <- string2treeErr gr s
s' <- newTree t x
uniqueRefinements cgr s'
--}
CAhead n -> action2command (goAheadN n)
CBack n -> action2command (goBackN n)
CTop -> action2command $ return . goRoot
@@ -215,34 +215,43 @@ execECommand env c = case c of
CWrapWithFun fi -> action2commandNext $ wrapWithFun cgr fi
CChangeHead f -> action2commandNext $ changeFunHead cgr f
CPeelHead -> action2commandNext $ peelFunHead cgr
-{- ----
- CAlphaConvert s -> action2commandNext $ \x ->
- string2varPair s >>= \xy -> alphaConvert gr xy x
+ CAlphaConvert s -> action2commandNext $ \x ->
+ string2varPair s >>= \xy -> alphaConvert cgr xy x
+{- ----
CRefineWithTree s -> action2commandNext $ \x ->
- (string2treeErr gr s x >>= \t -> refineWithTree der gr t x)
+ (string2treeErr cgr s x >>=
+ \t -> refineWithTree der cgr t x)
- CRefineParse str -> \s -> refineByExps der gr
+ CRefineParse str -> \s -> refineByTrees der cgr
(parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s
-}
+ CRefineParse str -> \s ->
+ let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s)))
+ ts = parseAny agrs cat str
+ in (if null ts ---- debug
+ then withMsg [str, "parse failed in cat" +++ show cat]
+ else id)
+ (refineByTrees der cgr ts) s
+
- CRefineRandom -> \s -> action2commandNext
- (refineRandom (stdGenCEnv env s) 41 cgr) s
+ CRefineRandom -> \s -> action2commandNext
+ (refineRandom (stdGenCEnv env s) 41 cgr) s
CSelectCand i -> selectCand cgr i
-{- ----
+
CTermCommand c -> case c of
"paraphrase" -> \s ->
- replaceByTermCommand gr c (actExp (stateSState s)) s
- "transfer" -> action2commandNext $
- transferSubTree (stateTransferFun sgr) gr
+ replaceByTermCommand der gr c (actTree (stateSState s)) s
+---- "transfer" -> action2commandNext $
+---- transferSubTree (stateTransferFun sgr) gr
_ -> replaceByEditCommand gr c
--}
+
---- CAddOption o -> changeStOptions (addOption o)
---- CRemoveOption o -> changeStOptions (removeOption o)
CDelete -> action2commandNext $ deleteSubTree cgr
CUndo -> undoCommand
----- CMenu -> \s -> changeMsg (menuState env s) s
+ CMenu -> \s -> changeMsg (menuState env s) s
CView -> changeView
CHelp h -> changeMsg [h env]
CVoid -> id
@@ -258,18 +267,16 @@ execECommand env c = case c of
--
-{- ----
string2varPair :: String -> Err (I.Ident,I.Ident)
string2varPair s = case words s of
x : y : [] -> liftM2 (,) (string2ident x) (string2ident y)
_ -> Bad "expected format 'x y'"
-
-- seen on display
cMenuDisplay :: String -> Command
cMenuDisplay s = CAddOption (menuDisplay s)
--}
+
newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) |
(c,[]) <- allCatsOf (canCEnv env)]
@@ -282,7 +289,7 @@ mkRefineMenuAll env sstate =
([],[],wraps) ->
[(CWrapWithFun fi, prWrap fit) | fit@(fi,_) <- wraps] ++
[(CChangeHead f, prChangeHead f) | f <- headChangesState cgr state] ++
- [(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
+ [(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
[(CDelete, (ifShort "d" "Delete", "d"))]
(refs,[],_) -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs]
(_,cands,_) -> [(CSelectCand i, prCand (t,i)) | (t,i) <- zip cands [0..]]
@@ -327,14 +334,17 @@ emptyMenuItem = (CVoid,("",""))
---- allStringCommands = snd $ customInfo customStringCommand
termCommandMenu, stringCommandMenu :: [(Command,String)]
-termCommandMenu = []
+termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
+
+allTermCommands = snd $ customInfo customEditCommand
+
stringCommandMenu = []
displayCommandMenu :: CEnv -> [(Command,String)]
displayCommandMenu env = []
{- ----
----- allTermCommands = snd $ customInfo customEditCommand
-termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
+
+termCommandMenu =
stringCommandMenu =
(CAddOption showStruct, "structured") :
@@ -367,7 +377,8 @@ displaySStateIn env state = (tree',msg,menu) where
grs = allStateGrammars env
lang = (viewSState state) `mod` (length grs + 3)
tree' = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang
- opts = addOptions (optsSState state) (globalOptions env) -- state opts override
+ opts = addOptions (optsSState state) -- state opts override
+ (addOption (markLin markOptFocus) (globalOptions env))
lin g = linearizeState fudWrap opts g zipper
exp = return $ tree2string $ loc2tree zipper
zipper = stateSState state
@@ -387,7 +398,8 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
(ls,grs) = unzip $ lgrs
lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
lins = (langAbstract, exp) : linAll
- opts = addOptions (optsSState state) (globalOptions env) -- state opts override
+ opts = addOptions (optsSState state) -- state opts override
+ (addOption (markLin markOptJava) (globalOptions env))
lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where
uni = optEncodeUTF8 n gr . mkUnicode
exp = prprTree $ loc2tree zipper
@@ -402,7 +414,7 @@ langXML = language "XML"
linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
linearizeState wrap opts gr =
- wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree
+ wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus
--- markedLinString br g
where
unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index bf84d776b..1048aab95 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -3,6 +3,7 @@ module Custom where
import Operations
import Text
import Tokenize
+import Values
import qualified Grammar as G
import qualified AbsGFC as A
import qualified GFC as C
@@ -22,6 +23,8 @@ import CFIdent
import PPrCF
import PrGrammar
+import Zipper
+
----import Morphology
-----import GrammarToHaskell
-----import GrammarToCanon (showCanon, showCanonOpt)
@@ -34,6 +37,8 @@ import MoreCustom -- either small/ or big/. The one in Small is empty.
import UseIO
+import Monad
+
-- minimal version also used in Hugs. AR 2/12/2002.
-- databases for customizable commands. AR 21/11/2001
@@ -59,10 +64,10 @@ customGrammarPrinter :: CustomData (StateGrammar -> String)
customSyntaxPrinter :: CustomData (GF.Grammar -> String)
-- termPrinter, "-printer=x"
-customTermPrinter :: CustomData (StateGrammar -> A.Exp -> String)
+customTermPrinter :: CustomData (StateGrammar -> Tree -> String)
-- termCommand, "-transform=x"
-customTermCommand :: CustomData (StateGrammar -> A.Exp -> [A.Exp])
+customTermCommand :: CustomData (StateGrammar -> Tree -> [Tree])
-- editCommand, "-edit=x"
customEditCommand :: CustomData (StateGrammar -> Action)
@@ -172,15 +177,15 @@ customTermCommand =
customData "Term transformers, selected by option -transform=x" $
[
(strCI "identity", \_ t -> [t]) -- DEFAULT
-{- ----
- ,(strCI "compute", \g t -> err (const [t]) return (computeAbsTerm g t))
- ,(strCI "paraphrase", \g t -> mkParaphrases g t)
- ,(strCI "typecheck", \g t -> err (const []) return (checkIfValidExp g t))
- ,(strCI "solve", \g t -> editAsTermCommand g
- (uniqueRefinements g) t)
- ,(strCI "context", \g t -> editAsTermCommand g
- (contextRefinements g) t)
--}
+ ,(strCI "compute", \g t -> let gr = grammar g in
+ err (const [t]) return
+ (exp2termCommand gr (computeAbsTerm gr) t))
+---- ,(strCI "paraphrase", \g t -> mkParaphrases g t)
+---- ,(strCI "typecheck", \g t -> err (const []) return (checkIfValidExp g t))
+ ,(strCI "solve", \g t -> err (const [t]) (return . loc2tree)
+ (uniqueRefinements (grammar g) (tree2loc t)))
+ ,(strCI "context", \g t -> err (const [t]) (return . loc2tree)
+ (contextRefinements (grammar g) (tree2loc t)))
--- ,(strCI "delete", \g t -> [MM.mExp0])
-- add your own term commands here
]
@@ -191,12 +196,10 @@ customEditCommand =
[
(strCI "identity", const return) -- DEFAULT
,(strCI "transfer", const return) --- done ad hoc on top level
-{- ----
- ,(strCI "typecheck", reCheckState)
- ,(strCI "solve", solveAll)
- ,(strCI "context", contextRefinements)
- ,(strCI "compute", computeSubTree)
--}
+ ,(strCI "typecheck", \g -> reCheckState (grammar g))
+ ,(strCI "solve", \g -> solveAll (grammar g))
+ ,(strCI "context", \g -> contextRefinements (grammar g))
+ ,(strCI "compute", \g -> computeSubTree (grammar g))
,(strCI "paraphrase", const return) --- done ad hoc on top level
-- add your own edit commands here
]
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
index 616ddc7cc..93038e9a0 100644
--- a/src/GF/UseGrammar/Editing.hs
+++ b/src/GF/UseGrammar/Editing.hs
@@ -129,6 +129,13 @@ newCat gr cat@(m,c) _ = do
testErr (null cont) "start cat must have null context" -- for easier meta refresh
initStateCat cont cat
+newFun :: CGrammar -> Fun -> Action
+newFun gr fun@(m,c) _ = do
+ typ <- lookupFunType gr m c
+ cat <- valCat typ
+ st1 <- newCat gr cat initState
+ refineWithAtom True gr (qq fun) st1
+
newTree :: Tree -> Action
newTree t _ = return $ tree2loc t
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
index da1bfce52..9cf391393 100644
--- a/src/GF/UseGrammar/Linear.hs
+++ b/src/GF/UseGrammar/Linear.hs
@@ -24,19 +24,17 @@ import Monad
-- NB. Constants in trees are annotated by the name of the abstract module.
-- A concrete module name must be given to find (and choose) linearization rules.
+-- If no marking is wanted, noMark :: Marker.
+-- For xml marking, use markXML :: Marker
linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
linearizeToRecord gr mk m = lin [] where
- lin ts t = errIn ("lint" +++ prt t) $ ----
- if A.isFocusNode (A.nodeTree t)
- then liftM markFocus $ lint ts t
- else lint ts t
-
- lint ts t@(Tr (n,xs)) = do
+ lin ts t@(Tr (n,xs)) = errIn ("linearization of" +++ prt t) $ do
let binds = A.bindsNode n
at = A.atomNode n
+ fmk = markSubtree mk n ts (A.isFocusNode n)
c <- A.val2cat $ A.valNode n
xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
@@ -47,7 +45,7 @@ linearizeToRecord gr mk m = lin [] where
A.AtV x -> lookCat c >>= comp [tK (prt at)]
A.AtM m -> lookCat c >>= comp [tK (prt at)]
- return $ mk ts $ mkBinds binds r
+ return $ fmk $ mkBinds binds r
look = lookupLin gr . redirectIdent m . rtQIdent
comp = ccompute gr
@@ -59,12 +57,6 @@ linearizeToRecord gr mk m = lin [] where
lookCat = return . errVal defLindef . look
---- should always be given in the module
-type Marker = [Int] -> Term -> Term
-
--- if no marking is wanted, use the following
-
-noMark :: [Int] -> Term -> Term
-noMark = const id
-- thus the special case:
@@ -115,9 +107,9 @@ strs2strings :: [[Str]] -> [String]
strs2strings = map unlex
-- finally, a top-level function to get a string from an expression
-linTree2string :: CanonGrammar -> Ident -> A.Tree -> String
-linTree2string gr m e = err id id $ do
- t <- linearizeNoMark gr m e
+linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
+linTree2string mk gr m e = err id id $ do
+ t <- linearizeToRecord gr mk m e
r <- expandLinTables gr t
ts <- rec2strTables r
let ss = strs2strings $ sTables2strs $ strTables2sTables ts
diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs
index dceb6acc6..a347560a0 100644
--- a/src/GF/UseGrammar/Randomized.hs
+++ b/src/GF/UseGrammar/Randomized.hs
@@ -15,16 +15,18 @@ import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc
myStdGen = mkStdGen ---
-- build one random tree; use mx to prevent infinite search
-mkRandomTree :: StdGen -> Int -> CGrammar -> QIdent -> Err Tree
+mkRandomTree :: StdGen -> Int -> CGrammar -> Either Cat Fun -> Err Tree
mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat
refineRandom :: StdGen -> Int -> CGrammar -> Action
refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen)
-- build a tree from a list of integers
-mkTreeFromInts :: [Int] -> CGrammar -> QIdent -> Err Tree
-mkTreeFromInts ints gr cat = do
- st0 <- newCat gr cat initState
+mkTreeFromInts :: [Int] -> CGrammar -> Either Cat Fun -> Err Tree
+mkTreeFromInts ints gr catfun = do
+ st0 <- either (\cat -> newCat gr cat initState)
+ (\fun -> newFun gr fun initState)
+ catfun
state <- mkStateFromInts ints gr st0
return $ loc2tree state
diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs
index bf2dd30ab..051630149 100644
--- a/src/GF/UseGrammar/Session.hs
+++ b/src/GF/UseGrammar/Session.hs
@@ -2,8 +2,9 @@ module Session where
import Abstract
import Option
----- import Custom
+import Custom
import Editing
+import ShellState ---- grammar
import Operations
@@ -50,6 +51,9 @@ changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss -- just change message
changeView :: ECommand
changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss -- toggle view
+withMsg :: [String] -> ECommand -> ECommand
+withMsg m c = changeMsg m . c
+
changeStOptions :: (Options -> Options) -> ECommand
changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss
@@ -90,21 +94,25 @@ refineByExps der gr trees = case trees of
[t] -> action2commandNext (refineWithExpTC der gr t)
_ -> changeCands trees
+refineByTrees :: Bool -> CGrammar -> [Tree] -> ECommand
+refineByTrees der gr trees = case trees of
+ [t] -> action2commandNext (refineWithTree der gr t)
+ _ -> changeCands $ map tree2exp trees
+
replaceByTrees :: CGrammar -> [Exp] -> ECommand
replaceByTrees gr trees = case trees of
[t] -> action2commandNext (\s ->
annotateExpInState gr t s >>= flip replaceSubTree s)
_ -> changeCands trees
-{- ----
-replaceByEditCommand :: CGrammar -> String -> ECommand
+replaceByEditCommand :: StateGrammar -> String -> ECommand
replaceByEditCommand gr co =
action2command $
maybe return ($ gr) $
lookupCustom customEditCommand (strCI co)
-replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand
-replaceByTermCommand gr co exp =
- replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $
- lookupCustom customTermCommand (strCI co)
--}
+replaceByTermCommand :: Bool -> StateGrammar -> String -> Tree -> ECommand ----
+replaceByTermCommand der gr co exp =
+ let g = grammar gr in
+ refineByTrees der g $ maybe [exp] (\f -> f gr exp) $
+ lookupCustom customTermCommand (strCI co)
diff --git a/src/Today.hs b/src/Today.hs
index 9bb6712ee..a1580bc1a 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Mon Sep 22 15:54:44 CEST 2003"
+module Today where today = "Wed Sep 24 17:15:34 CEST 2003"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:22:58 +0000