pipeline pretty printing from json

1 files changed, 39 insertions, 6 deletions

diff --git a/tool/Compiler.hs b/tool/Compiler.hs
index 215cf106..a1a9671b 100644
--- a/tool/Compiler.hs
+++ b/tool/Compiler.hs
@@ -3,6 +3,7 @@ import Options.Applicative
 import Data.Aeson
 import qualified Data.ByteString.Lazy as B
 import System.FilePath
+import qualified Text.Show.Pretty as PP
 
 import LambdaCube.Compiler
 
@@ -11,6 +12,7 @@ data Config
   { srcName :: String
   , backend :: Backend
   , includePaths :: [FilePath]
+  , pretty :: Bool
   }
 
 sample :: Parser Config
@@ -18,6 +20,7 @@ sample = Config
   <$> argument str (metavar "SOURCE_FILE")
   <*> flag OpenGL33 WebGL1 (long "webgl" <> help "generate WebGL 1.0 pipeline" )
   <*> pure ["."]
+  <*> switch (long "pretty" <> help "pretty prints pipeline")
 
 main :: IO ()
 main = compile =<< execParser opts
@@ -29,10 +32,40 @@ main = compile =<< execParser opts
 
 compile :: Config -> IO ()
 compile Config{..} = do
-  let dropExt n | takeExtension n == ".lc"  = dropExtension n
-      dropExt n = n
-      baseName = dropExt srcName
-  pplRes <- compileMain includePaths backend baseName
-  case pplRes of
+  let ext = takeExtension srcName
+      baseName | ext == ".lc" = dropExtension srcName
+               | otherwise = srcName
+  case ext of
+    ".json" | pretty -> prettyPrint srcName
+    _ -> do
+      pplRes <- compileMain includePaths backend baseName
+      case pplRes of
+        Left err -> putStrLn err
+        Right ppl -> case pretty of
+          False -> B.writeFile (baseName <> ".json") $ encode ppl
+          True -> writeFile (baseName <> ".ppl") $ ppUnlines $ PP.ppShow ppl
+
+prettyPrint :: String -> IO ()
+prettyPrint srcName = do
+  let baseName = dropExtension srcName
+  json <- B.readFile srcName
+  case eitherDecode json :: Either String Pipeline of
     Left err -> putStrLn err
-    Right ppl -> B.writeFile (baseName <> ".json") $ encode ppl
+    Right ppl -> writeFile (baseName <> ".ppl") $ ppUnlines $ PP.ppShow ppl
+
+ppUnlines :: String -> String
+ppUnlines = goPP 0
+  where goPP _ [] = []
+        goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
+          indent = replicate n ' '
+          go ('\\':'n':xs) = "\n" ++ indent ++ go xs
+          go ('\\':c:xs) = '\\':c:go xs
+          go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
+          go (x:xs) = x : go xs
+        goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
+
+        isMultilineString ('\\':'n':xs) = True
+        isMultilineString ('\\':c:xs) = isMultilineString xs
+        isMultilineString ('"':xs) = False
+        isMultilineString (x:xs) = isMultilineString xs
+        isMultilineString [] = False