From ba321be3ffa503f7e65cbde4c3ff99bcfae57c3e Mon Sep 17 00:00:00 2001
From: bjorn <bjorn@bringert.net>
Date: Fri, 26 Sep 2008 15:21:32 +0000
Subject: [PATCH] Added pgf-pretty output-format

---
 src/GF/Compile/Export.hs    |  2 +
 src/GF/Compile/PGFPretty.hs | 87 +++++++++++++++++++++++++++++++++++++
 src/GF/Infra/Option.hs      |  2 +
 3 files changed, 91 insertions(+)
 create mode 100644 src/GF/Compile/PGFPretty.hs

diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs
index 23817b70f..f24e840c3 100644
--- a/src/GF/Compile/Export.hs
+++ b/src/GF/Compile/Export.hs
@@ -7,6 +7,7 @@ import PGF.Raw.Convert (fromPGF)
 import GF.Compile.GFCCtoHaskell
 import GF.Compile.GFCCtoProlog
 import GF.Compile.GFCCtoJS
+import GF.Compile.PGFPretty
 import GF.Infra.Option
 import GF.Speech.CFG
 import GF.Speech.PGFToCFG
@@ -32,6 +33,7 @@ exportPGF :: Options
 exportPGF opts fmt pgf = 
     case fmt of
       FmtPGF          -> multi "pgf" printPGF
+      FmtPGFPretty    -> multi "txt" prPGFPretty
       FmtJavaScript   -> multi "js"  pgf2js
       FmtHaskell      -> multi "hs"  (grammar2haskell hsPrefix name)
       FmtHaskell_GADT -> multi "hs"  (grammar2haskellGADT hsPrefix name)
diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs
new file mode 100644
index 000000000..26df0204d
--- /dev/null
+++ b/src/GF/Compile/PGFPretty.hs
@@ -0,0 +1,87 @@
+-- | Print a part of a PGF grammar on the human-readable format used in 
+-- the paper "PGF: A Portable Run-Time Format for Type-Theoretical Grammars".
+module GF.Compile.PGFPretty (prPGFPretty) where
+
+import PGF.CId
+import PGF.Data
+import PGF.Macros
+
+import GF.Data.Operations
+import GF.Text.UTF8
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Text.PrettyPrint.HughesPJ
+
+
+prPGFPretty :: PGF -> String
+prPGFPretty pgf = render $ prAbs (abstract pgf) $$ prAll (prCnc (abstract pgf)) (concretes pgf)
+
+prAbs :: Abstr -> Doc
+prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
+
+prCat :: CId -> [Hypo] -> Doc
+prCat c h | isLiteralCat c = empty
+          | otherwise = text "cat" <+> text (prCId c)
+
+prFun :: CId -> (Type,Expr) -> Doc
+prFun f (t,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t
+
+prType :: Type -> Doc
+prType t = parens (hsep (punctuate (text ",") (map (text . prCId) cs))) <+> text "->" <+> text (prCId c)
+  where (cs,c) = catSkeleton t
+
+
+-- FIXME: show concrete name
+-- FIXME: inline opers first
+prCnc :: Abstr -> CId -> Concr -> Doc
+prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
+  where
+    prLinCat :: CId -> Term -> Doc
+    prLinCat c t | isLiteralCat c = empty
+                 | otherwise = text "lincat" <+> text (prCId c) <+> text "=" <+> pr t
+        where
+          pr (R ts) = hsep (punctuate (text " *") (map pr ts))
+          pr (S []) = text "Str"
+          pr (C n) = text "Int_" <> text (show (n+1))
+
+    prLin :: CId -> Term -> Doc
+    prLin f t = text "lin" <+> text (prCId f) <+> text "=" <+> pr 0 t
+        where
+          pr :: Int -> Term -> Doc
+          pr p (R [t]) = pr p t
+          pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">"
+          pr p (P t1 t2) = prec p 3 (pr 3 t1 <> text "!" <> pr 3 t2)
+          pr p (S ts) = prec p 2 (hsep (map (pr 2) ts))
+          pr p (K (KS t)) = doubleQuotes (text t)
+          pr p (V i) = text ("argv_" ++ show (i+1))
+          pr p (C i) = text (show (i+1))
+          pr p (FV ts) = prec p 1 (hsep (punctuate (text " |") (map (pr 1) ts)))
+          pr _ t = error $ "PGFPretty.prLin " ++ show t
+
+linCat :: Concr -> CId -> Term
+linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ prCId c) c (lincats cnc)
+
+prec :: Int -> Int -> Doc -> Doc
+prec p m | p >= m = parens
+         | otherwise = id
+
+expand :: Concr -> Concr
+expand cnc = cnc { lins = Map.map (f "") (lins cnc) }
+  where 
+    -- FIXME: handle KP
+    f :: String -> Term -> Term
+    f w (R ts) = R (map (f w) ts)
+    f "" (P t1 t2) = P (f "" t1) (f "" t2)
+    f w (S []) = S []
+    f w (S (t:ts)) = S (f w t : map (f "") ts)
+    f w (FV ts) = FV (map (f w) ts)
+    f w (W s t) = f (w++s) t
+    f w (K (KS t)) = K (KS (w++t))
+    f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ prCId o) o (opers cnc))
+    f w t = t
+
+-- Utilities
+
+prAll :: (a -> b -> Doc) -> Map a b -> Doc
+prAll p m = vcat [ p k v | (k,v) <- Map.toList m]
\ No newline at end of file
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index 111d2eedc..e9b70ccf7 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -81,6 +81,7 @@ data Encoding = UTF_8 | ISO_8859_1 | CP_1251
   deriving (Eq,Ord)
 
 data OutputFormat = FmtPGF 
+                  | FmtPGFPretty
                   | FmtJavaScript 
                   | FmtHaskell 
                   | FmtHaskell_GADT 
@@ -453,6 +454,7 @@ optDescr =
 outputFormats :: [(String,OutputFormat)]
 outputFormats = 
     [("pgf",          FmtPGF),
+     ("pgf-pretty",   FmtPGFPretty),
      ("js",           FmtJavaScript),
      ("haskell",      FmtHaskell),
      ("haskell_gadt", FmtHaskell_GADT),