From d444c6e386ad20aaf6a532966dcdb27bacb1be12 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 12 Aug 2016 13:57:12 +0200 Subject: [PATCH] Add check of syntactic validity of output --- brittany.cabal | 1 + src-brittany/Main.hs | 39 ++++++++++++++++--- src/Language/Haskell/Brittany.hs | 28 ++++++++++--- src/Language/Haskell/Brittany/Config.hs | 1 + src/Language/Haskell/Brittany/Config/Types.hs | 16 +++++++- .../Haskell/Brittany/ExactPrintUtils.hs | 21 ++++++---- src/Language/Haskell/Brittany/Types.hs | 8 ++-- 7 files changed, 91 insertions(+), 23 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 7595ef8..6a6342a 100644 --- a/brittany.cabal +++ b/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 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index a6defe1..df2cbf7 100644 --- a/src-brittany/Main.hs +++ b/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 LayoutErrorUnknownNode{} = 2 + customErrOrder LayoutErrorOutputCheck{} = 1 + 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 diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 8b5f5d5..fdcc0e7 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/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 - Left (_, s) -> Left $ "parsing error: " ++ s - Right (anns, parsedModule) -> - let (errs, ltext) = pPrintModule conf anns parsedModule - in if null errs + case parseResult of + Left (_, s) -> return $ Left $ "parsing error: " ++ s + Right (anns, parsedModule) -> do + (errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule + 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. diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs index d929e5e..8f96840 100644 --- a/src/Language/Haskell/Brittany/Config.hs +++ b/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 diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs index 7277879..4178f58 100644 --- a/src/Language/Haskell/Brittany/Config/Types.hs +++ b/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) - (ErrorHandlingConfig y1 y2) = ErrorHandlingConfig + cZip f (ErrorHandlingConfig x1 x2 x3) + (ErrorHandlingConfig y1 y2 y3) = ErrorHandlingConfig (f x1 y1) (f x2 y2) + (f x3 y3) instance CZip ForwardOptionsF where cZip f (ForwardOptions x1) diff --git a/src/Language/Haskell/Brittany/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/ExactPrintUtils.hs index 31d2bc7..99b7922 100644 --- a/src/Language/Haskell/Brittany/ExactPrintUtils.hs +++ b/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)) -parseModuleWithCpp cpp opts args fp = + -> (GHC.DynFlags -> IO (Either String a)) + -> 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)) -parseModuleFromString args fp str = + -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) +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 ----------- diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 19f9ca5..dcbba29 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -115,9 +115,11 @@ instance Show LayoutState where -- , _lsettings_initialAnns :: ExactPrint.Anns -- } -data LayoutError = LayoutErrorUnusedComment String - | LayoutWarning String - | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast +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,