Restored printnames.

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
 

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

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

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!
 

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

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

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"