3 files changed, 56 insertions, 41 deletions

diff --git a/Makefile b/Makefile
index 44cd956a..e23e7326 100644
--- a/Makefile
+++ b/Makefile
@@ -7,6 +7,9 @@ LCDIR=~/.cabal/share/x86_64-linux-ghc-7.10.3/lambdacube-compiler-0.5.0.0/lc
 repl:
         cd test && ghci -Wall -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-type-defaults -i../src -i../dist/build/autogen runTests.hs
 
+repllc:
+        cd tool && ghci -Wall -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-missing-signatures -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns -fno-warn-type-defaults -i../src -i../dist/build/autogen Compiler.hs
+
 copylc:
         cp lc/*.lc $(LCDIR)
 
diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs
index 4f0aba11..56d3db8a 100644
--- a/src/LambdaCube/Compiler.hs
+++ b/src/LambdaCube/Compiler.hs
@@ -16,7 +16,7 @@ module LambdaCube.Compiler
     , MM, runMM
     , catchErr
     , ioFetch, decideFilePath
-    , getDef, compileMain, preCompile
+    , getDef, compileMain, parseModule, preCompile
     , removeFromCache
 
     , compilePipeline
@@ -239,6 +239,12 @@ compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipelin
 compileMain path backend fname
     = fmap snd $ runMM (ioFetch path) $ compilePipeline' (const ()) backend fname
 
+parseModule :: [FilePath] -> MName -> IO (Either String String)
+parseModule path fname = runMM (ioFetch path) $ loadModule snd Nothing (Left fname) <&> \case
+    Left err -> Left err
+    Right (fname, (src, Left err)) -> Left err
+    Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos
+
 -- used by the compiler-service of the online editor
 preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either String IR.Pipeline, (Infos, String)))
 preCompile paths paths' backend mod = do
@@ -256,4 +262,7 @@ preCompile paths paths' backend mod = do
                 Left "Main"    -> return $ Right ("./Main.lc", "Main", return src)
                 n -> ioFetch paths' imp n
   where
-    ex = second (unlines . map ((++"\n") . removeEscs . ppShow))
+    ex = second pPrintStmts
+
+pPrintStmts = unlines . map ((++"\n") . removeEscs . ppShow)
+
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