add core dump option to cli

1 files changed, 15 insertions, 1 deletions

diff --git a/tool/Compiler.hs b/tool/Compiler.hs
index c8706b1b..2681795c 100644
--- a/tool/Compiler.hs
+++ b/tool/Compiler.hs
@@ -1,6 +1,7 @@
 import Data.Monoid
 import Control.Monad
 import Options.Applicative
+import Data.Either
 import Data.Aeson
 import qualified Data.ByteString.Lazy as B
 import System.FilePath
@@ -20,10 +21,17 @@ main = join $ execParser $ addInfo i $ versionOption <*> subparser (
           <*> pure ["."]
           <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name"))
     )
+ <> command "dump" (addInfo (progDesc "dumps LambdaCube3D core") $ dump
+          <$> argument str (metavar "SOURCE_FILE")
+          <*> flag OpenGL33 WebGL1 (long "webgl" <> help "generate WebGL 1.0 pipeline" )
+          <*> pure ["."]
+          <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name"))
+    )
  <> command "pretty" (addInfo (progDesc "pretty prints JSON IR") $ prettyPrint
       <$> argument str (metavar "SOURCE_FILE")
       <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name"))
-    )) <|> compile'
+    )
+ ) <|> compile'
   where
     compile' = (compile
           <$> argument str (metavar "SOURCE_FILE")
@@ -60,6 +68,12 @@ parse srcName backend includePaths output = do
         Left err -> fail $ show err
         Right ppl -> maybe (putStrLn ppl) (`writeFile` ppl) output
 
+dump srcName backend includePaths output = do
+    res <- runMM (ioFetch includePaths) $ getDef srcName "main" (Just outputType)
+    let Right e   = snd $ fromRight (error "compile error: can not dump the core, try regular compile to get the error message") $ snd res
+        coreDump  = show $ mkDoc (False,True) e
+    maybe (putStrLn coreDump) (`writeFile` coreDump) output
+
 compile srcName backend includePaths output = do
   let ext = takeExtension srcName
       baseName | ext == ".lc" = dropExtension srcName