summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Canon/CMacros.hs117
-rw-r--r--src/GF/Compile/GrammarToCanon.hs16
-rw-r--r--src/GF/Compile/Optimize.hs30
-rw-r--r--src/GF/Shell/Commands.hs49
-rw-r--r--src/GF/UseGrammar/Editing.hs14
-rw-r--r--src/GF/UseGrammar/Session.hs2
-rw-r--r--src/Today.hs2
7 files changed, 78 insertions, 152 deletions
diff --git a/src/GF/Canon/CMacros.hs b/src/GF/Canon/CMacros.hs
index 49e9c71e4..e782d977a 100644
--- a/src/GF/Canon/CMacros.hs
+++ b/src/GF/Canon/CMacros.hs
@@ -149,120 +149,5 @@ allLinValues trm = do
redirectIdent n f@(CIQ _ c) = CIQ n c
-
-{- ---- to be removed 21/9
--- to analyse types and terms into eta normal form
-
-typeForm :: Exp -> Err (Context, Exp, [Exp])
-typeForm e = do
- (cont,val) <- getContext e
- (cat,args) <- getArgs val
- return (cont,cat,args)
-
-getContext :: Exp -> Err (Context, Exp)
-getContext e = case e of
- EProd x a b -> do
- (g,b') <- getContext b
- return ((x,a):g,b')
- _ -> return ([],e)
-
-valAtom :: Exp -> Err Atom
-valAtom e = do
- (_,val,_) <- typeForm e
- case val of
- EAtom a -> return a
- _ -> prtBad "atom expected instead of" val
-
-valCat :: Exp -> Err CIdent
-valCat e = do
- a <- valAtom e
- case a of
- AC c -> return c
- _ -> prtBad "cat expected instead of" a
-
-termForm :: Exp -> Err ([A.Ident], Exp, [Exp])
-termForm e = do
- (cont,val) <- getBinds e
- (cat,args) <- getArgs val
- return (cont,cat,args)
-
-getBinds :: Exp -> Err ([A.Ident], Exp)
-getBinds e = case e of
- EAbs x b -> do
- (g,b') <- getBinds b
- return (x:g,b')
- _ -> return ([],e)
-
-getArgs :: Exp -> Err (Exp,[Exp])
-getArgs = get [] where
- get xs e = case e of
- EApp f a -> get (a:xs) f
- _ -> return (e, reverse xs)
-
--- the inverses of these
-
-mkProd :: Context -> Exp -> Exp
-mkProd c e = foldr (uncurry EProd) e c
-
-mkApp :: Exp -> [Exp] -> Exp
-mkApp = foldl EApp
-
-mkAppAtom :: Atom -> [Exp] -> Exp
-mkAppAtom a = mkApp (EAtom a)
-
-mkAppCons :: CIdent -> [Exp] -> Exp
-mkAppCons c = mkAppAtom $ AC c
-
-mkType :: Context -> Exp -> [Exp] -> Exp
-mkType c e xs = mkProd c $ mkApp e xs
-
-mkAbs :: Context -> Exp -> Exp
-mkAbs c e = foldr EAbs e $ map fst c
-
-mkTerm :: Context -> Exp -> [Exp] -> Exp
-mkTerm c e xs = mkAbs c $ mkApp e xs
-
-mkAbsR :: [A.Ident] -> Exp -> Exp
-mkAbsR c e = foldr EAbs e c
-
-mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp
-mkTermR c e xs = mkAbsR c $ mkApp e xs
-
--- this is used to create heuristic menus
-eqCatId :: Cat -> Atom -> Bool
-eqCatId (CIQ _ c) b = case b of
- AC (CIQ _ d) -> c == d
- AD (CIQ _ d) -> c == d
- _ -> False
-
--- a very weak notion of "compatible value category"
-compatCat :: Cat -> Type -> Bool
-compatCat c t = case t of
- EAtom b -> eqCatId c b
- EApp f _ -> compatCat c f
- _ -> False
-
--- this is the way an atomic category looks as a type
-
-cat2type :: Cat -> Type
-cat2type = EAtom . AC
-
-compatType :: Type -> Type -> Bool
-compatType t = case t of
- EAtom (AC c) -> compatCat c
- _ -> (t ==)
-
-type Fun = CIdent
-type Cat = CIdent
-type Type = Exp
-
-mkFun, mkCat :: String -> String -> Fun
-mkFun m f = CIQ (A.identC m) (A.identC f)
-mkCat = mkFun
-
-mkFunC, mkCatC :: String -> Fun
-mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f)
-mkCatC = mkFunC
-
--}
+ciq n f = CIQ n f
diff --git a/src/GF/Compile/GrammarToCanon.hs b/src/GF/Compile/GrammarToCanon.hs
index b097405de..23833a3c2 100644
--- a/src/GF/Compile/GrammarToCanon.hs
+++ b/src/GF/Compile/GrammarToCanon.hs
@@ -74,22 +74,22 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
ps' <- mapM redParam ps
returns c' $ C.ResPar ps'
- CncCat pty ptr ppr -> case (pty,ptr) of
- (Yes ty, Yes (Abs _ t)) -> do
+ CncCat pty ptr ppr -> case (pty,ptr,ppr) of
+ (Yes ty, Yes (Abs _ t), Yes pr) -> do
ty' <- redCType ty
trm' <- redCTerm t
- ppr' <- return $ G.FV [] ---- redCTerm
- return [(c', C.CncCat ty' trm' ppr')]
+ pr' <- redCTerm pr
+ return [(c', C.CncCat ty' trm' pr')]
_ -> prtBad "cannot reduce rule for" c
- CncFun mt ptr ppr -> case (mt,ptr) of
- (Just (cat,_), Yes trm) -> do
+ CncFun mt ptr ppr -> case (mt,ptr,ppr) of
+ (Just (cat,_), Yes trm, Yes pr) -> do
cat' <- redIdent cat
(xx,body,_) <- termForm trm
xx' <- mapM redArgvar xx
body' <- errIn (prt body) $ redCTerm body ---- debug
- ppr' <- return $ G.FV [] ---- redCTerm
- return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')]
+ pr' <- redCTerm pr
+ return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
_ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
AnyInd s b -> do
diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs
index c901c3911..07149bebf 100644
--- a/src/GF/Compile/Optimize.hs
+++ b/src/GF/Compile/Optimize.hs
@@ -82,7 +82,7 @@ evalCncInfo gr cnc abs (c,info) = case info of
return $ May b
_ -> return pde -- indirection
- ppr' <- return ppr ----
+ ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
return (c, CncCat ptyp pde' ppr')
@@ -92,9 +92,7 @@ evalCncInfo gr cnc abs (c,info) = case info of
Yes de -> do
liftM yes $ pEval ty de
_ -> return pde
- ppr' <- case ppr of
- Yes pr -> liftM yes $ comp pr
- _ -> return ppr
+ ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
_ -> return (c,info)
@@ -169,3 +167,27 @@ mkLinDefault gr typ = do
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ -> prtBad "linearization type field cannot be" typ
+-- Form the printname: if given, compute. If not, use the computed
+-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
+--- We cannot use linearization at this stage, since we do not know the
+--- defaults we would need for question marks - and we're not yet in canon.
+
+evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
+evalPrintname gr c ppr lin =
+ case ppr of
+ Yes pr -> comp pr
+ _ -> case lin of
+ Yes t -> return $ K $ prt $ oneBranch t ---- stringFromTerm
+ _ -> return $ K $ prt c ----
+ where
+ comp = computeConcrete gr
+
+ oneBranch t = case t of
+ Abs _ b -> oneBranch b
+ R (r:_) -> oneBranch $ snd $ snd r
+ T _ (c:_) -> oneBranch $ snd c
+ FV (t:_) -> oneBranch t
+ C x y -> C (oneBranch x) (oneBranch y)
+ S x _ -> oneBranch x
+ P x _ -> oneBranch x
+ _ -> t
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index 71ef3244b..3169582e0 100644
--- a/src/GF/Shell/Commands.hs
+++ b/src/GF/Shell/Commands.hs
@@ -3,10 +3,11 @@ module Commands where
import Operations
import Zipper
-import qualified Grammar as G ---- Cat, Fun
+import qualified Grammar as G ---- Cat, Fun, Q, QC
import GFC
import CMacros
import LookAbs
+import Look
import Values (loc2treeFocus)----
import GetTree
@@ -14,7 +15,6 @@ import API
import ShellState
import qualified Shell
-import qualified Ident as I
import qualified PShell
import qualified Macros as M
import PrGrammar
@@ -23,7 +23,6 @@ import IOGrammar
import UseIO
import Unicode
-import Option
import CF
import CFIdent (cat2CFCat, cfCat2Cat)
import Linear
@@ -32,10 +31,13 @@ import Editing
import Session
import Custom
-import Random (mkStdGen)
+import qualified Ident as I
+import Option
+import Str (sstr) ----
+
+import Random (mkStdGen, newStdGen)
import Monad (liftM2)
import List (intersperse)
-import Random (newStdGen)
--- temporary hacks for GF 2.0
@@ -105,10 +107,11 @@ abstractCEnv = absId
stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) ---
initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
----- Just cat -> action2commandNext (newCat gr (identC cat)) initSState
+ Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState
_ -> initSState
where
sgr = firstStateGrammar env
+ abs = absId sgr
gr = stateGrammarST sgr
-- the main function
@@ -274,8 +277,8 @@ string2varPair s = case words s of
cMenuDisplay :: String -> Command
cMenuDisplay s = CAddOption (menuDisplay s)
-newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) |
- (c,[]) <- allCatsOf (canCEnv env)]
+newCatMenu env = [(CNewCat c, printname env initSState c) |
+ (c,[]) <- allCatsOf (canCEnv env)]
mkRefineMenu :: CEnv -> SState -> [(Command,String)]
mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate]
@@ -293,7 +296,7 @@ mkRefineMenuAll env sstate =
where
prRef (f,t) =
- (ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t),
+ (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt t),
"r" +++ prRefinement f)
prChangeHead f =
(ifShort "ch" "ChangeHead" +++ prOrLinFun f,
@@ -314,11 +317,10 @@ mkRefineMenuAll env sstate =
_ -> b
ifShort = ifOpt sizeDisplay "short"
ifTyped t = ifOpt typeDisplay "typed" t ""
- prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t
- prOrLinTree t = case getOptVal opts menuDisplay of
- Just "Abs" -> prt t
- Just lang -> optLinearizeTreeVal (addOption firstLin opts)
- (stateGrammarOfLang env (language lang)) t
+ prOrLinExp t = prt t ----
+ prOrLinRef t = case t of
+ G.Q m f -> printname env sstate (m,f)
+ G.QC m f -> printname env sstate (m,f)
_ -> prt t
prOrLinFun = printname env sstate
@@ -364,9 +366,11 @@ menuState env = map snd . mkRefineMenu env
prState :: State -> [String]
prState s = prMarkedTree (loc2treeMarked s)
+displayJustStateIn :: CEnv -> SState -> String
displayJustStateIn env state = case displaySStateIn env state of
(t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF
+displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)])
displaySStateIn env state = (tree',msg,menu) where
(tree,msg,menu) = displaySState env state
grs = allStateGrammars env
@@ -380,6 +384,7 @@ displaySStateIn env state = (tree',msg,menu) where
linAll = map lin grs
separ = singleton . map unlines . intersperse [replicate 72 '*']
+displaySStateJavaX :: CEnv -> SState -> String
displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
tagXML "linearizations" (concat
[tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]),
@@ -391,7 +396,7 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
(tree,msg,menu) = displaySState env state
menu' = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu]
(ls,grs) = unzip $ lgrs
- lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
+ lgrs = allStateGrammarsWithNames env ---- allActiveStateGrammarsWithNames env
lins = (langAbstract, exp) : linAll
opts = addOptions (optsSState state) -- state opts override
(addOption (markLin mark) (globalOptions env))
@@ -406,14 +411,13 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
langAbstract = language "Abstract"
langXML = language "XML"
-
linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
linearizeState wrap opts gr =
wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus
where
- unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g
- strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand
+ unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr
+ strop = maybe id ($ gr) $ customAsOptVal opts filterString customStringCommand
br = oElem showStruct opts
noWrap, fudWrap :: String -> [String]
@@ -430,14 +434,17 @@ menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state]
printname :: CEnv -> SState -> G.Fun -> String
printname env state f = case getOptVal opts menuDisplay of
Just "Abs" -> prQIdent f
- Just lang -> printn lang
+ Just lang -> printn lang f
_ -> prQIdent f
where
opts = addOptions (optsSState state) (globalOptions env)
- printn lang = printOrLinearize gr m f where
+ printn lang f = err id (ifNull (prQIdent f) (sstr . head)) $ do
+ t <- lookupPrintname gr mf
+ strsFromTerm t
+ where
sgr = stateGrammarOfLang env (language lang)
gr = grammar sgr
- m = cncId sgr
+ mf = ciq (cncId sgr) (snd f)
--- XML printing; does not belong here!
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
index 93038e9a0..cd9fec9a4 100644
--- a/src/GF/UseGrammar/Editing.hs
+++ b/src/GF/UseGrammar/Editing.hs
@@ -164,9 +164,21 @@ noMoreMetas = err (const True) (const False) . goNextMeta
replaceSubTree :: Tree -> Action
replaceSubTree tree state = changeLoc state tree
+refineOrReplaceWithTree :: Bool -> CGrammar -> Tree -> Action
+refineOrReplaceWithTree der gr tree state = case actMeta state of
+ Ok m -> refineWithTreeReal der gr tree m state
+ _ -> do
+ let tree1 = addBinds (actBinds state) $ tree
+ state' <- replaceSubTree tree1 state
+ reCheckState gr state'
+
refineWithTree :: Bool -> CGrammar -> Tree -> Action
refineWithTree der gr tree state = do
- m <- errIn "move pointer to meta" $ actMeta state
+ m <- errIn "move pointer to meta" $ actMeta state
+ refineWithTreeReal der gr tree m state
+
+refineWithTreeReal :: Bool -> CGrammar -> Tree -> Meta -> Action
+refineWithTreeReal der gr tree m state = do
state' <- replaceSubTree tree state
let cs0 = allConstrs state'
(cs,ms) = splitConstraints cs0
diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs
index 051630149..81158a515 100644
--- a/src/GF/UseGrammar/Session.hs
+++ b/src/GF/UseGrammar/Session.hs
@@ -96,7 +96,7 @@ refineByExps der gr trees = case trees of
refineByTrees :: Bool -> CGrammar -> [Tree] -> ECommand
refineByTrees der gr trees = case trees of
- [t] -> action2commandNext (refineWithTree der gr t)
+ [t] -> action2commandNext (refineOrReplaceWithTree der gr t)
_ -> changeCands $ map tree2exp trees
replaceByTrees :: CGrammar -> [Exp] -> ECommand
diff --git a/src/Today.hs b/src/Today.hs
index 9259ba6b5..bf8573337 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Tue Oct 7 17:59:46 CEST 2003"
+module Today where today = "Wed Oct 8 11:43:12 CEST 2003"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 13:04:37 +0000