first version of parse only

1 files changed, 42 insertions, 39 deletions

diff --git a/tool/Compiler.hs b/tool/Compiler.hs
index ccc50d7d..359b23d6 100644
--- a/tool/Compiler.hs
+++ b/tool/Compiler.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards #-}
+import Control.Monad
 import Options.Applicative
 import Data.Aeson
 import qualified Data.ByteString.Lazy as B
@@ -8,53 +8,56 @@ import Paths_lambdacube_compiler (version)
 
 import LambdaCube.Compiler
 
-data Config
-  = Config
-  { srcName :: String
-  , backend :: Backend
-  , includePaths :: [FilePath]
-  , pretty :: Bool
-  , output :: Maybe String
-  }
-
-sample :: Parser Config
-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")
-  <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name"))
+addInfo i p = info (helper <*> p) i
 
 main :: IO ()
-main = compile =<< execParser opts
+main = join $ execParser $ addInfo i $ subparser (
+    command "compile" (addInfo (progDesc "compiles LambdaCube3D source to JSON IR") compile')
+ <> command "parse" (addInfo (progDesc "parses LambdaCube3D source") $ parse
+          <$> 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'
   where
-    opts = info (helper <*> sample)
-      ( fullDesc
-     <> progDesc "compiles LambdaCube graphics pipeline source to JSON IR"
-     <> header ("LambdaCube 3D compiler " ++ showVersion version))
+    compile' = (compile
+          <$> 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"))
+        )
 
-compile :: Config -> IO ()
-compile cfg@Config{..} = do
+    i = fullDesc
+     <> progDesc "executes command (default to compile if no command is given)"
+     <> header ("LambdaCube 3D compiler " ++ showVersion version)
+
+prettyPrint srcName output = do
+      let baseName = dropExtension srcName
+          withOutName n = maybe n id output
+      json <- B.readFile srcName
+      case eitherDecode json :: Either String Pipeline of
+        Left err -> putStrLn err
+        Right ppl -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl
+
+parse srcName backend includePaths output = do
+    pplRes <- parseModule includePaths srcName
+    case pplRes of
+        Left err -> fail err
+        Right ppl -> maybe (putStrLn ppl) (`writeFile` ppl) output
+
+compile srcName backend includePaths output = do
   let ext = takeExtension srcName
       baseName | ext == ".lc" = dropExtension srcName
                | otherwise = srcName
       withOutName n = maybe n id output
-  case ext of
-    ".json" | pretty -> prettyPrint cfg
-    _ -> do
+  do
       pplRes <- compileMain includePaths backend srcName
       case pplRes of
         Left err -> fail err
-        Right ppl -> case pretty of
-          False -> B.writeFile (withOutName $ baseName <> ".json") $ encode ppl
-          True -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl
-
-prettyPrint :: Config -> IO ()
-prettyPrint Config{..} = do
-  let baseName = dropExtension srcName
-      withOutName n = maybe n id output
-  json <- B.readFile srcName
-  case eitherDecode json :: Either String Pipeline of
-    Left err -> putStrLn err
-    Right ppl -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl
+        Right ppl -> B.writeFile (withOutName $ baseName <> ".json") $ encode ppl
+--          True -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl