rework the cli interface

brittany.cabal

@@ -102,7 +102,7 @@ library {
     , pretty >=1.1.3.3 && <1.2
     , bytestring >=0.10.8.1 && <0.11
     , directory >=1.2.6.2 && <1.4
-    , butcher >=1.1.0.0 && <1.2
+    , butcher >=1.2 && <1.3
     , yaml >=0.8.18 && <0.9
     , aeson >=1.0.1.0 && <1.3
     , extra >=1.4.10 && <1.7
@@ -147,7 +147,7 @@ executable brittany
   other-modules: {
     Paths_brittany
   }
-  -- other-extensions:    
+  -- other-extensions:
   build-depends:
     { brittany
     , base
@@ -335,7 +335,7 @@ test-suite littests
     }
   ghc-options:      -Wall
   main-is:          Main.hs
-  other-modules:    
+  other-modules:
   hs-source-dirs:   src-literatetests
   default-extensions: {
     CPP
@@ -379,7 +379,7 @@ test-suite libinterfacetests
     }
   ghc-options:      -Wall
   main-is:          Main.hs
-  other-modules:    
+  other-modules:
   hs-source-dirs:   src-libinterfacetests
   default-extensions: {
     FlexibleContexts

src-brittany/Main.hs

@@ -12,8 +12,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
 import qualified Data.Map as Map
 
+import           Text.Read (Read(..))
+import qualified Text.ParserCombinators.ReadP as ReadP
+import qualified Text.ParserCombinators.ReadPrec as ReadPrec
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
+import           Control.Monad (zipWithM)
 import           Data.CZipWith
 
 import qualified Debug.Trace as Trace
@@ -39,6 +43,17 @@ import qualified GHC.LanguageExtensions.Type as GHC
 import Paths_brittany
 
 
+data WriteMode = Display | Inplace
+
+instance Read WriteMode where
+  readPrec = val "display" Display <|> val "inplace" Inplace
+   where
+    val iden v = ReadPrec.lift $ ReadP.string iden >> return v
+
+instance Show WriteMode where
+  show Display = "display"
+  show Inplace = "inplace"
+
 
 main :: IO ()
 main = mainFromCmdParserWithHelpDesc mainCmdParser
@@ -103,8 +118,6 @@ mainCmdParser helpDesc = do
   printHelp      <- addSimpleBoolFlag "h" ["help"] mempty
   printVersion   <- addSimpleBoolFlag "" ["version"] mempty
   printLicense   <- addSimpleBoolFlag "" ["license"] mempty
-  inputPaths     <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "paths to input haskell source files")
-  outputPaths    <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file paths")
   configPaths    <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
   cmdlineConfig  <- configParser
   suppressOutput <- addSimpleBoolFlag
@@ -112,10 +125,17 @@ mainCmdParser helpDesc = do
     ["suppress-output"]
     (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")
   _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")
-  inplace    <- addSimpleBoolFlag "" ["inplace"] (flagHelp $ parDoc "overwrite the input files")
+  writeMode  <- addFlagReadParam
+    ""
+    ["write-mode"]
+    ""
+    Flag
+      { _flag_help    = Just (PP.text "output mode: [display|inplace]")
+      , _flag_default = Just Display
+      }
   reorderStop
-  inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")
+  inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files")
-  desc       <- peekCmdDesc
+  desc        <- peekCmdDesc
   addCmdImpl $ void $ do
     when printLicense $ do
       print licenseDoc
@@ -130,21 +150,10 @@ mainCmdParser helpDesc = do
       liftIO $ print $ ppHelpShallow desc
       System.Exit.exitSuccess
 
-    let inputPaths' = case maybeToList inputParam ++ inputPaths of
+    let inputPaths  = if null inputParams then [Nothing] else map Just inputParams
-                      [] -> [Nothing]
+    let outputPaths = case writeMode of
-                      ps -> map Just ps
+                      Display -> repeat Nothing
-
+                      Inplace -> inputPaths
-    outputPaths' <- case outputPaths of
-      [] | not inplace -> return [Nothing]
-      []               -> return inputPaths'
-      ps | not inplace -> return . map Just $ ps
-      _                -> do
-        putStrErrLn "cannot specify output files and inplace at the same time"
-        System.Exit.exitWith (System.Exit.ExitFailure 51)
-
-    when (length inputPaths' /= length outputPaths') $ do
-      putStrErrLn "the number of inputs must match ther number of outputs"
-      System.Exit.exitWith (System.Exit.ExitFailure 52)
 
     config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case
       Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
@@ -152,9 +161,8 @@ mainCmdParser helpDesc = do
     when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
       trace (showConfigYaml config) $ return ()
 
-    let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths'
+    results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths
-    res <- fmap sequence_ $ sequence ios
+    case sequence_ results of
-    case res of
       Left  _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
       Right _ -> pure ()
 

stack.yaml

@@ -3,7 +3,7 @@ resolver: lts-9.0
 extra-deps:
   - monad-memo-0.4.1
   - czipwith-1.0.0.0
-  - butcher-1.1.0.2
+  - butcher-1.2.0.0
   - data-tree-print-0.1.0.0
   - deque-0.2