hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Refactor a bit (Internal.ppDecl -> Decl.layoutDecl)

pull/141/head
Lennart Spitzner 2018-04-25 20:15:47 +02:00
parent e9aacb27ff
commit 929e465fd4
3 changed files with 57 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
src/Language/Haskell/Brittany/Internal.hs
View File

@ -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)

22
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -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

30
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -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 */