From 3d5d424fef5df225416085fd36e0b19a61dcd809 Mon Sep 17 00:00:00 2001
From: "john.j.camilleri" <john.j.camilleri@chalmers.se>
Date: Fri, 18 Jan 2013 09:39:50 +0000
Subject: [PATCH] Add fun/cat printnames to PGF web service

This is accessible vis the `browse` command, by adding the flag `printnames`
e.g.: .../Letter.pgf?command=browse&id=Recipient&format=json&printnames=1
---
 src/server/PGFService.hs | 31 +++++++++++++++++++++++--------
 1 file changed, 23 insertions(+), 8 deletions(-)

diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index 71c4f37d3..a353207f1 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -72,7 +72,7 @@ pgfMain command pgf =
                              Just l <- getFrom
                              outputGraphviz (parseTree pgf l t)
       "abstrjson"      -> outputJSONP . jsonExpr =<< getTree
-      "browse"         -> id =<< doBrowse pgf `fmap` getOptId `ap` getCSSClass `ap` getHRef `ap` getFormat "html"
+      "browse"         -> id =<< doBrowse pgf `fmap` getOptId `ap` getCSSClass `ap` getHRef `ap` getFormat "html" `ap` getIncludePrintNames
       "external"       -> do cmd <- getInput "external"
                              input <- getText
                              doExternal cmd input
@@ -140,6 +140,9 @@ pgfMain command pgf =
                          Nothing -> throwCGIError 400 "Bad language" ["Bad language: " ++ l]
                          Just lang | lang `elem` PGF.languages pgf -> return $ Just lang
                                    | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l]
+    
+    getIncludePrintNames :: CGI Bool
+    getIncludePrintNames = maybe (return False) (\_->return True) =<< getInput "printnames"
 
 
 errorMissingId = throwCGIError 400 "Missing identifier" []
@@ -372,20 +375,24 @@ pipeIt2graphviz format code = do
      ExitSuccess   -> return output
      ExitFailure r -> fail ("pipeIt2graphviz: (exit " ++ show r ++ ")")
 
-browse1json pgf id = makeObj . maybe [] obj $ PGF.browse pgf id
+browse1json pgf id pn = makeObj . maybe [] obj $ PGF.browse pgf id
   where
-    obj (def,ps,cs) = ["def".=def,"producers".=ps,"consumers".=cs]
+    obj (def,ps,cs) = if pn then (baseobj ++ pnames) else baseobj
+      where
+        baseobj = ["def".=def, "producers".=ps, "consumers".=cs]
+        pnames = ["printnames".=makeObj [(show lang).=PGF.showPrintName pgf lang id | lang <- PGF.languages pgf]]
 
-doBrowse pgf (Just id) _ _ "json" = outputJSONP $ browse1json pgf id
-doBrowse pgf Nothing   _ _ "json" =
+
+doBrowse pgf (Just id) _ _ "json" pn = outputJSONP $ browse1json pgf id pn
+doBrowse pgf Nothing   _ _ "json" pn =
     outputJSONP $ makeObj ["cats".=all (PGF.categories pgf),
                            "funs".=all (PGF.functions pgf)]
   where
     all = makeObj . map one
-    one id = PGF.showCId id.=browse1json pgf id
+    one id = PGF.showCId id.=browse1json pgf id pn
 
-doBrowse pgf Nothing cssClass href _ = errorMissingId
-doBrowse pgf (Just id) cssClass href _ = -- default to "html" format
+doBrowse pgf Nothing cssClass href _ pn = errorMissingId
+doBrowse pgf (Just id) cssClass href _ pn = -- default to "html" format
   outputHTML $
   case PGF.browse pgf id of
     Just (def,ps,cs) -> "<PRE>"++annotate def++"</PRE>\n"++
@@ -399,6 +406,11 @@ doBrowse pgf (Just id) cssClass href _ = -- default to "html" format
                            then "<BR/>"++
                                 "<H3>Consumers</H3>"++
                                 "<P>"++annotateCIds cs++"</P>\n"
+                           else "")++
+                        (if pn
+                           then "<BR/>"++
+                                "<H3>Print Names</H3>"++
+                                "<P>"++annotatePrintNames++"</P>\n"
                            else "")
     Nothing          -> ""
   where
@@ -459,6 +471,9 @@ doBrowse pgf (Just id) cssClass href _ = -- default to "html" format
         Just s  -> "class=\""++s++"\""
 
     mkLink s = "<A "++hrefAttr s++" "++classAttr++">"++s++"</A>"
+    
+    annotatePrintNames = "<DL>"++(unwords pns)++"</DL>"
+      where pns = ["<DT>"++(show lang)++"</DT><DD>"++(PGF.showPrintName pgf lang id)++"</DD>" | lang <- PGF.languages pgf ]
 
 instance JSON PGF.CId where
     readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage