From 5dbe0f2c9c0fa6e42722806cc4f7f0e713006bf5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 22 May 2017 21:04:19 +0200 Subject: [PATCH] Add function pureModuleTransform --- brittany.cabal | 5 +- src-brittany/Main.hs | 19 +++--- src/Language/Haskell/Brittany.hs | 83 ++++++++++++++++++++++++-- src/Language/Haskell/Brittany/Types.hs | 9 ++- 4 files changed, 100 insertions(+), 16 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 1ab460d..d97e2d2 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -108,6 +108,7 @@ library { , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 , unordered-containers >=0.2.7 && <0.3 + , ghc-boot-th >=8.0.1 && <8.1 } default-extensions: { CPP @@ -169,9 +170,9 @@ executable brittany , cmdargs , czipwith , unordered-containers + , ghc-boot-th , hspec >=2.4.1 && <2.5 , filepath >=1.4.1.0 && <1.5 - , ghc-boot-th >=8.0.1 && <8.1 } hs-source-dirs: src-brittany default-language: Haskell2010 @@ -248,6 +249,7 @@ test-suite unittests , cmdargs , czipwith , unordered-containers + , ghc-boot-th , hspec >=2.4.1 && <2.5 } ghc-options: -Wall @@ -322,6 +324,7 @@ test-suite littests , cmdargs , czipwith , unordered-containers + , ghc-boot-th , hspec >=2.4.1 && <2.5 , parsec >=3.1.11 && <3.2 } diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 9ddd5a6..3991079 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -111,6 +111,11 @@ mainCmdParser helpDesc = do trace (showConfigYaml config) $ return () 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 + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & runIdentity & Semigroup.getLast -- the flag will do the following: insert a marker string -- ("-- BRITTANY_INCLUDE_HACK ") right before any lines starting with @@ -147,21 +152,15 @@ mainCmdParser helpDesc = do when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () - -- mapM_ printErr (Map.toList anns) - -- let L _ (HsModule name exports imports decls _ _) = parsedSource - -- let someDecls = take 3 decls - -- -- let out = ExactPrint.exactPrint parsedSource anns - -- let out = do - -- decl <- someDecls - -- ExactPrint.exactPrint decl anns - let omitCheck = config & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack (errsWarns, outLText) <- 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 let hackF s = fromMaybe s $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s pure $ if hackAroundIncludes then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) else (ews, outRaw) - let customErrOrder LayoutWarning{} = 0 :: Int + let customErrOrder LayoutErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int customErrOrder LayoutErrorOutputCheck{} = 1 customErrOrder LayoutErrorUnusedComment{} = 2 customErrOrder LayoutErrorUnknownNode{} = 3 @@ -170,6 +169,8 @@ mainCmdParser helpDesc = do groupedErrsWarns `forM_` \case (LayoutErrorOutputCheck{}:_) -> do putStrErrLn $ "ERROR: brittany pretty printer" ++ " returned syntactically invalid result." + (LayoutErrorInput str:_) -> do + putStrErrLn $ "ERROR: parse error: " ++ str 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 dc77b76..6a74465 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} module Language.Haskell.Brittany - ( parsePrintModule + ( pureModuleTransform + , parsePrintModule , pPrintModule , pPrintModuleAndCheck -- re-export from utils: @@ -18,7 +19,10 @@ import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Generics as SYB +import Data.Data +import Control.Monad.Trans.Either +import Data.HList.HList +import Data.CZipWith import qualified Data.Text.Lazy.Builder as Text.Builder @@ -45,10 +49,73 @@ import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC -import Data.HList.HList +-- | Exposes the transformation in an pseudo-pure fashion. The signature +-- contains `IO` due to the GHC API not exposing a pure parsing function, but +-- there should be no observable effects. +-- +-- Note that this function ignores/resets all config values regarding +-- debugging, i.e. it will never use `trace`/write to stderr. +pureModuleTransform :: CConfig Option -> Text -> IO (Either [LayoutError] Text) +pureModuleTransform oConfigRaw inputText = runEitherT $ do + let configRaw = cZipWith fromOptionIdentity staticDefaultConfig oConfigRaw + let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + let config_pp = config & _conf_preprocessor + let cppMode = config_pp & _ppconf_CPPMode & confUnpack + let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack + (anns, parsedSource, hasCPP) <- do + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITTANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes + then List.unlines . fmap hackF . List.lines + else id + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + parseResult <- lift $ parseModuleFromString + ghcOptions + "stdin" + cppCheckFunc + (hackTransform $ Text.unpack inputText) + case parseResult of + Left err -> left $ [LayoutErrorInput err] + Right x -> pure $ x + (errsWarns, outputTextL) <- do + let omitCheck = + config + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule config anns parsedSource + else lift $ pPrintModuleAndCheck config anns parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITTANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then (ews, TextL.unlines $ fmap hackF $ TextL.lines outRaw) + else (ews, outRaw) + let customErrOrder LayoutErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder LayoutErrorOutputCheck{} = 1 + customErrOrder LayoutErrorUnusedComment{} = 2 + customErrOrder LayoutErrorUnknownNode{} = 3 + let hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + if hasErrors + then left $ errsWarns + else pure $ TextL.toStrict outputTextL + -- LayoutErrors can be non-fatal warnings, thus both are returned instead -- of an Either. @@ -115,7 +182,11 @@ parsePrintModule conf filename input = do case parseResult of Left (_ , s ) -> return $ Left $ "parsing error: " ++ s Right (anns, parsedModule) -> do - let omitCheck = conf & _conf_errorHandling .> _econf_omit_output_valid_check .> confUnpack + let omitCheck = + conf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack (errs, ltext) <- if omitCheck then return $ pPrintModule conf anns parsedModule else pPrintModuleAndCheck conf anns parsedModule @@ -124,6 +195,7 @@ parsePrintModule conf filename input = do else let errStrs = errs <&> \case + LayoutErrorInput str -> str LayoutErrorUnusedComment str -> str LayoutWarning str -> str LayoutErrorUnknownNode str _ -> str @@ -131,6 +203,7 @@ parsePrintModule conf filename input = do in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs + -- this approach would for with there was a pure GHC.parseDynamicFilePragma. -- Unfortunately that does not exist yet, so we cannot provide a nominally -- pure interface. @@ -215,7 +288,7 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) _ -> return () -withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM () +withTransformedAnns :: Data ast => ast -> PPM () -> PPM () withTransformedAnns ast m = do -- TODO: implement `local` for MultiReader/MultiRWS readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR diff --git a/src/Language/Haskell/Brittany/Types.hs b/src/Language/Haskell/Brittany/Types.hs index 941a922..fabd6bf 100644 --- a/src/Language/Haskell/Brittany/Types.hs +++ b/src/Language/Haskell/Brittany/Types.hs @@ -115,10 +115,17 @@ instance Show LayoutState where -- } data LayoutError - = LayoutErrorUnusedComment String + = LayoutErrorInput String + -- ^ parsing failed + | LayoutErrorUnusedComment String + -- ^ internal error: some comment went missing | LayoutWarning String + -- ^ some warning | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast + -- ^ internal error: pretty-printing is not implemented for type of node + -- in the syntax-tree | LayoutErrorOutputCheck + -- ^ checking the output for syntactic validity failed data BriSpacing = BriSpacing { _bs_spacePastLineIndent :: Int -- space in the current,