Add check of syntactic validity of output

brittany.cabal

@@ -139,6 +139,7 @@ executable brittany
     , safe
     , filepath >=1.4.1.0 && <1.5
     , either
+    , ghc-boot-th
     }
   hs-source-dirs:      src-brittany
   default-language:    Haskell2010

src-brittany/Main.hs

@@ -31,6 +31,9 @@ import qualified System.Exit
 import qualified System.Directory as Directory
 import qualified System.FilePath.Posix as FilePath
 
+import qualified DynFlags as GHC
+import qualified GHC.LanguageExtensions.Type as GHC
+
 import Paths_brittany
 
 
@@ -105,16 +108,35 @@ mainCmdParser = do
                    & _options_ghc
                    & runIdentity
     liftIO $ do
+      let cppMode = config
+                  & _conf_errorHandling
+                  & _econf_CPPMode
+                  & runIdentity
+                  & Semigroup.getLast
+      let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
+            then case cppMode of
+              CPPModeAbort -> do
+                return $ Left "Encountered -XCPP. Aborting."
+              CPPModeWarn -> do
+                putStrErrLn
+                  $  "Warning: Encountered -XCPP."
+                  ++ " Be warned that -XCPP is not supported and that"
+                  ++ " brittany cannot check that its output is syntactically"
+                  ++ " valid in its presence."
+                return $ Right True
+              CPPModeNowarn ->
+                return $ Right True
+            else return $ Right False
       parseResult <- case inputPathM of
-        Nothing -> parseModuleFromString ghcOptions "stdin"
+        Nothing -> parseModuleFromString ghcOptions "stdin" cppCheckFunc
                    =<< System.IO.hGetContents System.IO.stdin
-        Just p -> parseModule ghcOptions p
+        Just p -> parseModule ghcOptions p cppCheckFunc
       case parseResult of
         Left left -> do
           putStrErrLn "parse error:"
           printErr left
           System.Exit.exitWith (System.Exit.ExitFailure 60)
-        Right (anns, parsedSource) -> do
+        Right (anns, parsedSource, hasCPP) -> do
           when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do
             let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
             trace ("---- ast ----\n" ++ show val) $ return ()
@@ -125,15 +147,20 @@ mainCmdParser = do
           -- let out = do
           --       decl <- someDecls
           --       ExactPrint.exactPrint decl anns
-          let (errsWarns, outLText) = pPrintModule config anns parsedSource
+          (errsWarns, outLText) <- if hasCPP
+            then return $ pPrintModule config anns parsedSource
+            else pPrintModuleAndCheck config anns parsedSource
           let customErrOrder LayoutWarning{}            = 0 :: Int
-              customErrOrder LayoutErrorUnusedComment{} = 1
+              customErrOrder LayoutErrorOutputCheck{}   = 1
-              customErrOrder LayoutErrorUnknownNode{}   = 2
+              customErrOrder LayoutErrorUnusedComment{} = 2
+              customErrOrder LayoutErrorUnknownNode{}   = 3
           when (not $ null errsWarns) $ do
             let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder
                                  $ List.sortOn customErrOrder
                                  $ errsWarns
             groupedErrsWarns `forM_` \case
+              (LayoutErrorOutputCheck{}:_) -> do
+                putStrErrLn $ "ERROR: brittany pretty printer returned syntactically invalid result."
               uns@(LayoutErrorUnknownNode{}:_) -> do
                 putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
                 uns `forM_` \case

src/Language/Haskell/Brittany.hs

@@ -3,6 +3,7 @@
 module Language.Haskell.Brittany
   ( parsePrintModule
   , pPrintModule
+  , pPrintModuleAndCheck
    -- re-export from utils:
   , parseModule
   , parseModuleFromString
@@ -79,6 +80,22 @@ pPrintModule conf anns parsedModule =
   --   debugStrings `forM_` \s ->
   --     trace s $ return ()
 
+-- | Additionally checks that the output compiles again, appending an error
+-- if it does not.
+pPrintModuleAndCheck
+  :: Config
+  -> ExactPrint.Types.Anns
+  -> GHC.ParsedSource
+  -> IO ([LayoutError], TextL.Text)
+pPrintModuleAndCheck conf anns parsedModule = do
+  let (errs, output) = pPrintModule conf anns parsedModule
+  parseResult <- ExactPrint.Parsers.parseModuleFromString "output" (TextL.unpack output)
+  let errs' = errs ++ case parseResult of
+        Left{}  -> [LayoutErrorOutputCheck]
+        Right{} -> []
+  return (errs', output)
+
+
 -- used for testing mostly, currently.
 parsePrintModule
   :: Config
@@ -88,17 +105,18 @@ parsePrintModule
 parsePrintModule conf filename input = do
   let inputStr = Text.unpack input
   parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
-  return $ case parseResult of
+  case parseResult of
-    Left (_, s) -> Left $ "parsing error: " ++ s
+    Left (_, s) -> return $ Left $ "parsing error: " ++ s
-    Right (anns, parsedModule) ->
+    Right (anns, parsedModule) -> do
-      let (errs, ltext) = pPrintModule conf anns parsedModule
+      (errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
-      in if null errs
+      return $ if null errs
         then Right $ TextL.toStrict $ ltext
         else
           let errStrs = errs <&> \case
                 LayoutErrorUnusedComment str -> str
                 LayoutWarning str -> str
                 LayoutErrorUnknownNode str _ -> str
+                LayoutErrorOutputCheck -> "Output is not syntactically valid."
           in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
 
 -- this approach would for with there was a pure GHC.parseDynamicFilePragma.

src/Language/Haskell/Brittany/Config.hs

@@ -123,6 +123,7 @@ configParser = do
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
       , _econf_Werror                = wrapLast $ falseToNothing wError
+      , _econf_CPPMode               = Nothing
       }
     , _conf_forward = ForwardOptions
       { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs

src/Language/Haskell/Brittany/Config/Types.hs

@@ -64,6 +64,7 @@ data ForwardOptionsF f = ForwardOptions
 data ErrorHandlingConfigF f = ErrorHandlingConfig
   { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
   , _econf_Werror                :: f (Semigroup.Last Bool)
+  , _econf_CPPMode               :: f (Semigroup.Last CPPMode)
   }
   deriving (Generic)
 
@@ -123,6 +124,8 @@ instance FromJSON IndentPolicy
 instance ToJSON   IndentPolicy
 instance FromJSON AltChooser
 instance ToJSON   AltChooser
+instance FromJSON CPPMode
+instance ToJSON   CPPMode
 
 instance FromJSON (LayoutConfigF Maybe)
 instance ToJSON   (LayoutConfigF Maybe)
@@ -181,6 +184,13 @@ data AltChooser = AltChooserSimpleQuick -- always choose last alternative.
                                         -- options having sufficient space.
   deriving (Show, Generic, Data)
 
+data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP
+             | CPPModeWarn   -- warn about CPP and non-roundtripping in its
+                             -- presence.
+             | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is
+                             -- file.)
+  deriving (Show, Generic, Data)
+
 staticDefaultConfig :: Config
 staticDefaultConfig = Config
     { _conf_debug = DebugConfig
@@ -208,6 +218,7 @@ staticDefaultConfig = Config
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors = coerce False
       , _econf_Werror                = coerce False
+      , _econf_CPPMode               = coerce CPPModeAbort
       }
     , _conf_forward = ForwardOptions
       { _options_ghc = Identity []
@@ -247,10 +258,11 @@ instance CZip LayoutConfigF where
     (f x7 y7)
 
 instance CZip ErrorHandlingConfigF where
-  cZip f (ErrorHandlingConfig x1 x2)
+  cZip f (ErrorHandlingConfig x1 x2 x3)
-         (ErrorHandlingConfig y1 y2) = ErrorHandlingConfig
+         (ErrorHandlingConfig y1 y2 y3) = ErrorHandlingConfig
     (f x1 y1)
     (f x2 y2)
+    (f x3 y3)
 
 instance CZip ForwardOptionsF where
   cZip f (ForwardOptions x1)

src/Language/Haskell/Brittany/ExactPrintUtils.hs

@@ -64,7 +64,8 @@ import DataTreePrint
 parseModule
   :: [String]
   -> System.IO.FilePath
-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+  -> (GHC.DynFlags -> IO (Either String a))
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
 parseModule =
   parseModuleWithCpp ExactPrint.defaultCppOptions ExactPrint.normalLayout
 
@@ -74,8 +75,9 @@ parseModuleWithCpp
   -> ExactPrint.DeltaOptions
   -> [String]
   -> System.IO.FilePath
-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+  -> (GHC.DynFlags -> IO (Either String a))
-parseModuleWithCpp cpp opts args fp =
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
+parseModuleWithCpp cpp opts args fp dynCheck =
   ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
     dflags0                       <- lift $ ExactPrint.initDynFlags fp
     (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine
@@ -89,17 +91,20 @@ parseModuleWithCpp cpp opts args fp =
       $  EitherT.left
       $  "when parsing ghc flags: encountered warnings: "
       ++ show (warnings <&> \(L _ s) -> s)
+    x <- EitherT.EitherT $ liftIO $ dynCheck dflags1
     res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags1 fp
     EitherT.hoistEither
-      $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err)
+               (\(a, m) -> Right (a, m, x))
       $ ExactPrint.postParseTransform res opts
 
 parseModuleFromString
   :: [String]
   -> System.IO.FilePath
+  -> (GHC.DynFlags -> IO (Either String a))
   -> String
-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource))
+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
-parseModuleFromString args fp str =
+parseModuleFromString args fp dynCheck str =
   ExactPrint.ghcWrapper $ EitherT.runEitherT $ do
     dflags0                       <- lift $ ExactPrint.initDynFlagsPure fp str
     (dflags1, leftover, warnings) <-
@@ -112,8 +117,10 @@ parseModuleFromString args fp str =
       $  EitherT.left
       $  "when parsing ghc flags: encountered warnings: "
       ++ show (warnings <&> \(L _ s) -> s)
+    x <- EitherT.EitherT $ liftIO $ dynCheck dflags1
     EitherT.hoistEither
-      $ either (\(span, err) -> Left $ show span ++ ": " ++ err) Right
+      $ either (\(span, err) -> Left $ show span ++ ": " ++ err)
+               (\(a, m) -> Right (a, m, x))
       $ ExactPrint.parseWith dflags1 fp GHC.parseModule str
 
 -----------

src/Language/Haskell/Brittany/Types.hs

@@ -115,9 +115,11 @@ instance Show LayoutState where
 --   , _lsettings_initialAnns :: ExactPrint.Anns
 --   }
 
-data LayoutError = LayoutErrorUnusedComment String
+data LayoutError
+  = LayoutErrorUnusedComment String
   | LayoutWarning String
   | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast
+  | LayoutErrorOutputCheck
 
 data BriSpacing = BriSpacing
   { _bs_spacePastLineIndent :: Int -- space in the current,