diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index b4c59b9..6bc70eb 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -450,10 +450,12 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do let config' = cZipWith fromOptionIdentity config $ mconcat (inlineModConf : (catMaybes (mBindingConfs ++ [mDeclConf]))) - toLocal config' filteredAnns - $ if (config' & _conf_roundtrip_exactprint_only & confUnpack) - then briDocMToPPM (briDocByExactNoComment decl) >>= layoutBriDoc - else ppDecl decl + let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack + toLocal config' filteredAnns $ do + bd <- briDocMToPPM $ if exactprintOnly + then briDocByExactNoComment decl + else layoutDecl decl + layoutBriDoc bd let finalComments = filter (fst .> \case @@ -477,19 +479,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () -withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () -withTransformedAnns ast m = do - -- TODO: implement `local` for MultiReader/MultiRWS - readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR - MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) - m - MultiRWSS.mPutRawR readers - where - f anns = - let ((), (annsBalanced, _), _) = - ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) - in annsBalanced - getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames (L _ decl) = case decl of @@ -498,38 +487,6 @@ getDeclBindingNames (L _ decl) = case decl of _ -> [] -ppDecl :: LHsDecl GhcPs -> PPMLocal () -ppDecl d@(L loc decl) = case decl of - SigD sig -> -- trace (_sigHead sig) $ - withTransformedAnns d $ do - -- runLayouter $ Old.layoutSig (L loc sig) - briDoc <- briDocMToPPM $ layoutSig (L loc sig) - layoutBriDoc briDoc - ValD bind -> -- trace (_bindHead bind) $ - withTransformedAnns d $ do - -- Old.layoutBind (L loc bind) - briDoc <- briDocMToPPM $ do - eitherNode <- layoutBind (L loc bind) - case eitherNode of - Left ns -> docLines $ return <$> ns - Right n -> return n - layoutBriDoc briDoc - InstD (TyFamInstD{}) -> do - -- this is a (temporary (..)) workaround for "type instance" decls - -- that do not round-trip through exactprint properly. - let fixer s = case List.stripPrefix "type " s of - Just rest | not ("instance" `isPrefixOf` rest) -> - "type instance " ++ rest - _ -> s - str <- mAsk <&> \anns -> - intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns - bd <- briDocMToPPM $ allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) - (foldedAnnKeys d) - False - (Text.pack str) - layoutBriDoc bd - _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc - -- Prints the information associated with the module annotation -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule GhcPs) diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 19bc835..375c779 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -7,6 +7,7 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils , commentAnnFixTransformGlob , extractToplevelAnns , foldedAnnKeys + , withTransformedAnns ) where @@ -17,6 +18,8 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Utils +import Data.Data +import Data.HList.HList import DynFlags ( getDynFlags ) import GHC ( runGhc, GenLocated(L), moduleNameString ) @@ -266,6 +269,25 @@ foldedAnnKeys ast = SYB.everything where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) +withTransformedAnns + :: Data ast + => ast + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a + -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a +withTransformedAnns ast m = do + -- TODO: implement `local` for MultiReader/MultiRWS + readers@(conf :+: anns :+: HNil) <- MultiRWSS.mGetRawR + MultiRWSS.mPutRawR (conf :+: f anns :+: HNil) + x <- m + MultiRWSS.mPutRawR readers + pure x + where + f anns = + let ((), (annsBalanced, _), _) = + ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) + in annsBalanced + + #if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat (GHC.Warn _ (L _ s)) = s diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 53f58b7..d4e8bce 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -2,7 +2,8 @@ {-# LANGUAGE TypeApplications #-} module Language.Haskell.Brittany.Internal.Layouters.Decl - ( layoutSig + ( layoutDecl + , layoutSig , layoutBind , layoutLocalBinds , layoutGuardLStmt @@ -20,6 +21,11 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint +import Language.Haskell.Brittany.Internal.ExactPrintUtils +import Language.Haskell.Brittany.Internal.Utils + import GHC ( runGhc, GenLocated(L), moduleNameString ) import SrcLoc ( SrcSpan ) import HsSyn @@ -40,6 +46,28 @@ import Bag ( mapBagM ) +layoutDecl :: ToBriDoc HsDecl +layoutDecl d@(L loc decl) = case decl of + SigD sig -> withTransformedAnns d $ layoutSig (L loc sig) + ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case + Left ns -> docLines $ return <$> ns + Right n -> return n + InstD (TyFamInstD{}) -> do + -- this is a (temporary (..)) workaround for "type instance" decls + -- that do not round-trip through exactprint properly. + let fixer s = case List.stripPrefix "type " s of + Just rest | not ("instance" `isPrefixOf` rest) -> + "type instance " ++ rest + _ -> s + str <- mAsk <&> \anns -> + intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns + allocateNode $ BDFExternal (ExactPrint.mkAnnKey d) + (foldedAnnKeys d) + False + (Text.pack str) + _ -> briDocByExactNoComment d + + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */