Add pretty-printing of LPGF grammars, to help debugging

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -29,7 +29,7 @@ mkCanon2lpgf :: Options -> SourceGrammar -> ModuleName -> IOE LPGF
 mkCanon2lpgf opts gr am = do
   debug <- isJust <$> lookupEnv "DEBUG"
   when debug $ do
-    writeCanonical debugDir canon
+    ppCanonical debugDir canon
     dumpCanonical debugDir canon
   (an,abs) <- mkAbstract ab
   cncs     <- mapM mkConcrete cncs
@@ -38,7 +38,7 @@ mkCanon2lpgf opts gr am = do
     L.abstract = abs,
     L.concretes = Map.fromList cncs
   }
-  when debug $ dumpLPGF debugDir lpgf
+  when debug $ ppLPGF debugDir lpgf
   return lpgf
   where
     canon@(C.Grammar ab cncs) = grammar2canonical opts am gr
@@ -332,13 +332,9 @@ fi2i (C.FunId i) = mkCId i
 debugDir :: FilePath
 debugDir = "DEBUG"
 
--- -- | Pretty-print canonical grammar to console
--- ppCanonical :: C.Grammar -> IO ()
--- ppCanonical = putStrLn . render . pp
-
 -- | Pretty-print canonical grammars to file
-writeCanonical :: FilePath -> C.Grammar -> IO ()
+ppCanonical :: FilePath -> C.Grammar -> IO ()
-writeCanonical path (C.Grammar ab cncs) = do
+ppCanonical path (C.Grammar ab cncs) = do
   let (C.Abstract modId flags cats funs) = ab
   writeFile (path </> mdi2s modId <.> "canonical.gf") (render $ pp ab)
   forM_ cncs $ \cnc@(C.Concrete modId absModId flags params lincats lindefs) ->
@@ -361,6 +357,12 @@ dumpCanonical path (C.Grammar ab cncs) = do
           ]
     writeFile' (path </> mdi2s modId <.> "canonical.dump") body
 
+-- | Pretty-print LPGF to file
+ppLPGF :: FilePath -> LPGF -> IO ()
+ppLPGF path lpgf =
+  forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) ->
+    writeFile' (path </> showCId cid <.> "lpgf.txt") (T.unpack $ L.render $ L.pp concr)
+
 -- | Dump LPGF to file
 dumpLPGF :: FilePath -> LPGF -> IO ()
 dumpLPGF path lpgf =

src/runtime/haskell/LPGF.hs

@@ -11,7 +11,8 @@ import PGF.CId
 import PGF.Expr (Expr)
 import PGF.Tree (Tree (..), expr2tree, prTree)
 
-import Control.Monad (liftM, liftM2)
+import Control.Monad (liftM, liftM2, forM_)
+import qualified Control.Monad.Writer as CMW
 import Data.Binary (Binary, put, get, putWord8, getWord8, encodeFile, decodeFile)
 import qualified Data.Map as Map
 import Data.Text (Text)
@@ -229,3 +230,69 @@ lin2string l = case l of
 isInt :: LinFun -> Bool
 isInt (LFInt _) = True
 isInt _ = False
+
+-- | Helper for building concat trees
+mkConcat :: [LinFun] -> LinFun
+mkConcat [] = LFEmpty
+mkConcat [x] = x
+mkConcat xs = foldl1 LFConcat xs
+
+-- | Helper for unfolding concat trees
+unConcat :: LinFun -> [LinFun]
+unConcat (LFConcat l1 l2) = concatMap unConcat [l1, l2]
+unConcat lf = [lf]
+
+------------------------------------------------------------------------------
+-- Pretty-printing
+
+type Doc = CMW.Writer [Text] ()
+
+render :: Doc -> Text
+render = T.unlines . CMW.execWriter
+
+class PP a where
+  pp :: a -> Doc
+
+instance PP LPGF where
+  pp (LPGF _ _ cncs) = mapM_ pp cncs
+
+instance PP Concrete where
+  pp (Concrete lins) =
+    forM_ (Map.toList lins) $ \(cid,lin) -> do
+      CMW.tell [T.pack ("# " ++ showCId cid)]
+      pp lin
+      CMW.tell [""]
+
+instance PP LinFun where
+  pp = pp' 0
+    where
+      pp' n = \case
+        LFPre ps d -> do
+          p "LFPre"
+          CMW.tell [ T.replicate (n+1) "  " `T.append` T.pack (show p) | p <- ps ]
+          pp' (n+1) d
+
+        c@(LFConcat l1 l2) | isDeep l1 || isDeep l2 -> do
+          p "LFConcat"
+          mapM_ (pp' (n+1)) (unConcat c)
+        LFTuple ls | any isDeep ls -> do
+          p "LFTuple"
+          mapM_ (pp' (n+1)) ls
+        LFProjection l1 l2 | isDeep l1 || isDeep l2 -> do
+          p "LFProjection"
+          pp' (n+1) l1
+          pp' (n+1) l2
+        t -> ps $ show t
+        where
+          p :: Text -> Doc
+          p t = CMW.tell [ T.replicate n "  " `T.append` t ]
+          ps :: String -> Doc
+          ps = p . T.pack
+
+      isDeep = not . isTerm
+      isTerm = \case
+        LFPre _ _ -> False
+        LFConcat _ _ -> False
+        LFTuple _ -> False
+        LFProjection _ _ -> False
+        _ -> True