Refactor Main.hs in preparation of --inplace (see #40)

src-brittany/Main.hs

@@ -90,6 +90,7 @@ licenseDoc = PP.vcat $ List.intersperse
     ]
   ]
 
+
 mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
 mainCmdParser helpDesc = do
   addCmdSynopsis "haskell source pretty printer"
@@ -116,10 +117,10 @@ mainCmdParser helpDesc = do
   desc       <- peekCmdDesc
   addCmdImpl $ void $ do
     when printLicense $ do
-      liftIO $ print licenseDoc
+      print licenseDoc
       System.Exit.exitSuccess
     when printVersion $ do
-      liftIO $ do
+      do
         putStrLn $ "brittany version " ++ showVersion version
         putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner"
         putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
@@ -132,22 +133,41 @@ mainCmdParser helpDesc = do
         return Nothing
       [x] -> return $ Just x
       _   -> do
-        liftIO $ putStrErrLn $ "more than one input, aborting"
+        putStrErrLn $ "more than one input, aborting"
         System.Exit.exitWith (System.Exit.ExitFailure 50)
-    outputPath <- case outputPaths of
+    outputPathM <- case outputPaths of
       [] -> do
         return Nothing
       [x] -> return $ Just x
       _   -> do
-        liftIO $ putStrErrLn $ "more than one output, aborting"
+        putStrErrLn $ "more than one output, aborting"
         System.Exit.exitWith (System.Exit.ExitFailure 50)
     config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case
       Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50)
       Just x  -> return x
     when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
       trace (showConfigYaml config) $ return ()
+    eitherErrSucc <- coreIO putStrErrLn config suppressOutput inputPathM outputPathM
+    case eitherErrSucc of
+      Left errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo)
+      Right ()   -> pure ()
+
+
+-- | The main IO parts for the default mode of operation, and after commandline
+-- and config stuff is processed.
+coreIO
+  :: (String -> IO ()) -- ^ error output function. In parallel operation, you
+                       -- may want serialize the different outputs and
+                       -- consequently not directly print to stderr.
+  -> Config -- ^ global program config.
+  -> Bool   -- ^ whether to supress output (to stdout). Purely IO flag, so
+            -- currently not part of program config.
+  -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.
+  -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.
+  -> IO (Either Int ())      -- ^ Either an errorNo, or success.
+coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEitherT $ do
+  let putErrorLn = liftIO . putErrorLnIO :: String -> EitherT.EitherT e IO ()
   let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-    liftIO $ do
   -- there is a good of code duplication between the following code and the
   -- `pureModuleTransform` function. Unfortunately, there are also a good
   -- amount of slight differences: This module is a bit more verbose, and
@@ -165,7 +185,7 @@ mainCmdParser helpDesc = do
           CPPModeAbort -> do
             return $ Left "Encountered -XCPP. Aborting."
           CPPModeWarn -> do
-                putStrErrLn
+            putErrorLnIO
               $  "Warning: Encountered -XCPP."
               ++ " Be warned that -XCPP is not supported and that"
               ++ " brittany cannot check that its output is syntactically"
@@ -179,14 +199,14 @@ mainCmdParser helpDesc = do
       let hackF s = if "#include" `isPrefixOf` s then "-- BRITTANY_INCLUDE_HACK " ++ s else s
       let hackTransform =
             if hackAroundIncludes && not exactprintOnly then List.unlines . fmap hackF . List.lines else id
-          inputString <- System.IO.hGetContents System.IO.stdin
+      inputString <- liftIO $ System.IO.hGetContents System.IO.stdin
-          parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)
+      liftIO $ parseModuleFromString ghcOptions "stdin" cppCheckFunc (hackTransform inputString)
-        Just p -> parseModule ghcOptions p cppCheckFunc
+    Just p -> liftIO $ parseModule ghcOptions p cppCheckFunc
   case parseResult of
     Left left -> do
-          putStrErrLn "parse error:"
+      putErrorLn "parse error:"
-          printErr left
+      putErrorLn $ show left
-          System.Exit.exitWith (System.Exit.ExitFailure 60)
+      EitherT.left 60
     Right (anns, parsedSource, hasCPP) -> do
       when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
         let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
@@ -199,11 +219,9 @@ mainCmdParser helpDesc = do
             let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack
             (ews, outRaw) <- if hasCPP || omitCheck
               then return $ pPrintModule config anns parsedSource
-                  else pPrintModuleAndCheck config anns parsedSource
+              else liftIO $ pPrintModuleAndCheck config anns parsedSource
             let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s
-                pure $ if hackAroundIncludes
+            pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw)
-                  then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw)
-                  else (ews, outRaw)
       let customErrOrder ErrorInput{}         = 4
           customErrOrder LayoutWarning{}      = 0 :: Int
           customErrOrder ErrorOutputCheck{}   = 1
@@ -213,31 +231,31 @@ mainCmdParser helpDesc = do
         let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder $ List.sortOn customErrOrder $ errsWarns
         groupedErrsWarns `forM_` \case
           (ErrorOutputCheck{}:_) -> do
-                putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
+            putErrorLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result."
           (ErrorInput str:_) -> do
-                putStrErrLn $ "ERROR: parse error: " ++ str
+            putErrorLn $ "ERROR: parse error: " ++ str
           uns@(ErrorUnknownNode{}:_) -> do
-                putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
+            putErrorLn $ "ERROR: encountered unknown syntactical constructs:"
             uns `forM_` \case
               ErrorUnknownNode str ast -> do
-                    putStrErrLn str
+                putErrorLn str
                 when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do
-                      putStrErrLn $ "  " ++ show (astToDoc ast)
+                  putErrorLn $ "  " ++ show (astToDoc ast)
               _ -> error "cannot happen (TM)"
           warns@(LayoutWarning{}:_) -> do
-                putStrErrLn $ "WARNINGS:"
+            putErrorLn $ "WARNINGS:"
             warns `forM_` \case
-                  LayoutWarning str -> putStrErrLn str
+              LayoutWarning str -> putErrorLn str
               _                 -> error "cannot happen (TM)"
           unused@(ErrorUnusedComment{}:_) -> do
-                putStrErrLn
+            putErrorLn
               $  "Error: detected unprocessed comments."
               ++ " The transformation output will most likely"
               ++ " not contain certain of the comments"
               ++ " present in the input haskell source file."
-                putStrErrLn $ "Affected are the following comments:"
+            putErrorLn $ "Affected are the following comments:"
             unused `forM_` \case
-                  ErrorUnusedComment str -> putStrErrLn str
+              ErrorUnusedComment str -> putErrorLn str
               _                      -> error "cannot happen (TM)"
           [] -> error "cannot happen"
       -- TODO: don't output anything when there are errors unless user
@@ -248,11 +266,11 @@ mainCmdParser helpDesc = do
           outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors & confUnpack
           shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs)
 
-          when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of
+      when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPathM of
-            Nothing -> TextL.IO.putStr $ outLText
+        Nothing -> liftIO $ TextL.IO.putStr $ outLText
-            Just p  -> TextL.IO.writeFile p $ outLText
+        Just p  -> liftIO $ TextL.IO.writeFile p $ outLText
 
-          when hasErrors $ System.Exit.exitWith (System.Exit.ExitFailure 70)
+      when hasErrors $ EitherT.left 70
  where
   addTraceSep conf =
     if or
@@ -269,6 +287,7 @@ mainCmdParser helpDesc = do
       then trace "----"
       else id
 
+
 readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config
 readConfigs cmdlineConfig configPaths = do
   let defLocalConfigPath = "brittany.yaml"