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"