From a979508aa75a3f2b93072d214ca9c75ed874a39c Mon Sep 17 00:00:00 2001
From: aarne <unknown>
Date: Wed, 8 Oct 2003 10:09:58 +0000
Subject: Restored printnames.

---
 src/GF/Compile/GrammarToCanon.hs | 16 ++++++++--------
 src/GF/Compile/Optimize.hs       | 30 ++++++++++++++++++++++++++----
 2 files changed, 34 insertions(+), 12 deletions(-)

(limited to 'src/GF/Compile')

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
-- 
cgit v1.2.3