added API for print names

src/compiler/GF/Compile/GeneratePMCFG.hs

@@ -32,10 +32,15 @@ generatePMCFG opts cwd gr cmo@(cm,cmi) = do
   js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi))
   return (cm,cmi{jments = (Map.fromAscList js)})
 
-addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
+addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) = do
-  checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do
+  rules <- checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $
-    rules <- pmcfgForm gr term ctxt val
+             pmcfgForm gr term ctxt val
-    return (id,CncFun mty mlin mprn (Just rules))
+  mprn  <- case mprn of
+             Nothing          -> return Nothing
+             Just (L loc prn) -> checkInModule cwd cmi loc ("Happened in the computation of the print name for" <+> id) $ do
+                                   prn <- normalForm gr prn
+                                   return (Just (L loc prn))
+  return (id,CncFun mty mlin mprn (Just rules))
 addPMCFG opts cwd gr cmi id_info = return id_info
 
 pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [Production]

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -90,10 +90,18 @@ grammar2PGF opts gr am probs = do
       createLincat (i2i c) (type2fields gr ty)
     createCncCats _ = return ()
 
-    createCncFuns ((m,f),CncFun _ _ _ (Just prods)) = do
+    createCncFuns ((m,f),CncFun _ _ mprn (Just prods)) = do
       createLin (i2i f) prods
+      case mprn of
+        Nothing        -> return ()
+        Just (L _ prn) -> setPrintName (i2i f) (unwords (term2tokens prn))
     createCncFuns _ = return ()
 
+    term2tokens (K tok)     = [tok]
+    term2tokens (C t1 t2)   = term2tokens t1 ++ term2tokens t2
+    term2tokens (Typed t _) = term2tokens t
+    term2tokens _           = []
+
 i2i :: Ident -> String
 i2i = showIdent
 

src/runtime/c/pgf/pgf.cxx

@@ -1889,6 +1889,42 @@ void pgf_bracketed_linearize(PgfDB *db, PgfConcrRevision revision,
     } PGF_API_END
 }
 
+PGF_API
+PgfText *pgf_get_printname(PgfDB *db, PgfConcrRevision revision,
+                           PgfText *fun, PgfExn* err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+        PgfText *printname = namespace_lookup(concr->printnames, fun)->printname;
+        return textdup(printname);
+    } PGF_API_END
+
+    return NULL;
+}
+
+PGF_API
+void pgf_set_printname(PgfDB *db, PgfConcrRevision revision,
+                       PgfText *fun, PgfText *name, PgfExn* err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        ref<PgfConcrPrintname> printname = PgfDB::malloc<PgfConcrPrintname>(fun->size+1);
+        printname->ref_count = 1;
+        memcpy(&printname->name, fun, sizeof(PgfText)+fun->size+1);
+        printname->printname = textdup_db(name);
+
+        Namespace<PgfConcrPrintname> printnames =
+            namespace_insert(concr->printnames, printname);
+        namespace_release(concr->printnames);
+        concr->printnames = printnames;
+    } PGF_API_END
+}
+
 PGF_API
 PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
                                PgfText *name,

src/runtime/c/pgf/pgf.h

@@ -630,6 +630,14 @@ void pgf_bracketed_linearize(PgfDB *db, PgfConcrRevision revision,
                              PgfLinearizationOutputIface *out,
                              PgfExn* err);
 
+PGF_API_DECL
+PgfText *pgf_get_printname(PgfDB *db, PgfConcrRevision revision,
+                           PgfText *fun, PgfExn* err);
+
+PGF_API_DECL
+void pgf_set_printname(PgfDB *db, PgfConcrRevision revision,
+                       PgfText *fun, PgfText *name, PgfExn* err);
+
 PGF_API_DECL
 PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
                                PgfText *name,

src/runtime/haskell/PGF2.hsc

@@ -415,7 +415,14 @@ concreteFlag c name =
               return (Just lit)
 
 printName :: Concr -> Fun -> Maybe String
-printName lang fun = error "TODO: printName"
+printName c fun =
+  unsafePerformIO $
+  withText fun $ \c_fun ->
+  withForeignPtr (c_revision c) $ \c_revision ->
+  bracket (withPgfExn "printName" (pgf_get_printname (c_db c) c_revision c_fun)) free $ \c_name -> do
+    if c_name /= nullPtr
+      then fmap Just $ peekText c_name
+      else return Nothing
 
 alignWords :: Concr -> Expr -> [(String, [Int])]
 alignWords = error "TODO: alignWords"

src/runtime/haskell/PGF2/FFI.hsc

@@ -210,6 +210,10 @@ foreign import ccall "wrapper" wrapSymbol2 :: Wrapper (Ptr PgfLinearizationOutpu
 
 foreign import ccall "wrapper" wrapSymbol3 :: Wrapper (Ptr PgfLinearizationOutputIface -> CInt -> IO ())
 
+foreign import ccall pgf_get_printname :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfText)
+
+foreign import ccall pgf_set_printname :: Ptr PgfDB -> Ptr Concr -> Ptr PgfText -> Ptr PgfText -> Ptr PgfExn -> IO ()
+
 foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
 
 foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()

src/runtime/haskell/PGF2/Transactions.hsc

@@ -24,6 +24,7 @@ module PGF2.Transactions
           , dropLincat
           , createLin
           , dropLin
+          , setPrintName
           ) where
 
 import PGF2.FFI
@@ -344,3 +345,9 @@ dropLin :: Fun -> Transaction Concr ()
 dropLin name = Transaction $ \c_db _ c_revision c_exn ->
   withText name $ \c_name ->
     pgf_drop_lin c_db c_revision c_name c_exn
+
+setPrintName :: Fun -> String -> Transaction Concr ()
+setPrintName fun name = Transaction $ \c_db _ c_revision c_exn ->
+  withText fun $ \c_fun ->
+  withText name $ \c_name -> do
+    withPgfExn "setPrintName" (pgf_set_printname c_db c_revision c_fun c_name)

src/runtime/haskell/tests/basic.pmcfg

@@ -19,10 +19,10 @@ concrete basic_cnc {
   lincat S = [
            ""
          ]
-  lin c : ∀{j<2} . N(j) -> S(0) = [
+  lin c : ∀{i<2} . N(i) -> S(0) = [
         <0,0>
       ]
-  lin ind : ∀{j<2} . P(0) * P(0) * N(j) -> P(0) = [
+  lin ind : ∀{i<2} . P(0) * P(0) * N(i) -> P(0) = [
       ]
   lin s : N(0) -> N(0) = [
         <0,0> "+" "1"

src/runtime/haskell/tests/basic_cnc.gf

@@ -3,6 +3,9 @@ concrete basic_cnc of basic = open Prelude in {
 lincat N = {s : Str; is_zero : Bool} ;
 lincat S = Str ;
 
+printname fun z = "0" ;
+printname fun s = "1" ;
+
 lin z = {s="0"; is_zero=True} ;
     s n = {
       s = case n.is_zero of {