Add function pureModuleTransform

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
     }

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

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

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,