From 4d650306c078e62ea2edd1c1b404927b101cbd21 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <lsp@informatik.uni-kiel.de>
Date: Sat, 6 Aug 2016 00:13:50 +0200
Subject: [PATCH] Implement a first pre-processing annotation transformation
---
src/Language/Haskell/Brittany.hs | 68 ++++++++++++++++++-
src/Language/Haskell/Brittany/LayoutBasics.hs | 6 +-
2 files changed, 69 insertions(+), 5 deletions(-)
diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs
index 5765e0e..e3e0261 100644
--- a/src/Language/Haskell/Brittany.hs
+++ b/src/Language/Haskell/Brittany.hs
@@ -38,6 +38,9 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess
+
+import qualified Data.Generics as SYB
+
import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder
@@ -52,6 +55,14 @@ import Language.Haskell.Brittany.Layouters.Decl
import Language.Haskell.Brittany.Utils
import Language.Haskell.Brittany.BriLayouter
+import RdrName ( RdrName(..) )
+import GHC ( runGhc, GenLocated(L), moduleNameString )
+import SrcLoc ( SrcSpan )
+import HsSyn
+import Name
+import qualified FastString
+import BasicTypes
+
-- LayoutErrors can be non-fatal warnings, thus both are returned instead
@@ -64,16 +75,18 @@ pPrintModule
-> GHC.ParsedSource
-> ([LayoutError], TextL.Text)
pPrintModule conf anns parsedModule =
- let ((out, errs), debugStrings)
+ let ((), (annsBalanced, _), _) =
+ ExactPrint.runTransform anns (commentAnnFixTransform parsedModule)
+ ((out, errs), debugStrings)
= runIdentity
$ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW
- $ MultiRWSS.withMultiReader anns
+ $ MultiRWSS.withMultiReader annsBalanced
$ MultiRWSS.withMultiReader conf
$ do
- traceIfDumpConf "bridoc annotations" _dconf_dump_annotations $ annsDoc anns
+ traceIfDumpConf "bridoc annotations" _dconf_dump_annotations $ annsDoc annsBalanced
ppModule parsedModule
tracer = if Seq.null debugStrings
then id
@@ -107,6 +120,55 @@ parsePrintModule conf filename input = do
LayoutErrorUnknownNode str _ -> str
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
+-- TODO: move to separate module
+commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
+commentAnnFixTransform modul = SYB.everything (>>) genF modul
+ where
+ genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
+ genF = (\_ -> return ()) `SYB.extQ` exprF
+ exprF :: Located (HsExpr RdrName) -> ExactPrint.Transform ()
+ exprF lexpr@(L _ expr) = case expr of
+ RecordCon _lname _ _ (HsRecFields fs@(_:_) Nothing) ->
+ moveTrailingComments lexpr (List.last fs)
+ RecordUpd _lname fs@(_:_) _ _ _ _ ->
+ moveTrailingComments lexpr (List.last fs)
+ _ -> return ()
+
+moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
+ => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
+moveTrailingComments astFrom astTo = do
+ let
+ breakHet :: (a -> Either b c) -> [a] -> ([b],[c])
+ breakHet _ [] = ([],[])
+ breakHet fn (a1:aR) = case fn a1 of
+ Left b -> (b:bs,cs)
+ Right c -> (bs,c:cs)
+ where
+ (bs,cs) = breakHet fn aR
+
+ k1 = ExactPrint.Types.mkAnnKey astFrom
+ k2 = ExactPrint.Types.mkAnnKey astTo
+ moveComments ans = ans'
+ where
+ an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
+ an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
+ cs1f = ExactPrint.Types.annFollowingComments an1
+ cs2f = ExactPrint.Types.annFollowingComments an2
+ (comments, nonComments) = flip breakHet (ExactPrint.Types.annsDP an1)
+ $ \case
+ (ExactPrint.Types.AnnComment com, dp) -> Left (com, dp)
+ x -> Right x
+ an1' = an1
+ { ExactPrint.annsDP = nonComments
+ , ExactPrint.annFollowingComments = []
+ }
+ an2' = an2
+ { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
+ }
+ ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
+
+ ExactPrint.modifyAnnsT moveComments
+
-- 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.
diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs
index 664b455..5eb0d85 100644
--- a/src/Language/Haskell/Brittany/LayoutBasics.hs
+++ b/src/Language/Haskell/Brittany/LayoutBasics.hs
@@ -728,10 +728,12 @@ extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann ->
[r | let r = ExactPrint.Types.annPriorComments ann, not (null r)]
extractCommentsPost :: ExactPrint.Types.Anns -> PostMap
extractCommentsPost anns = flip Map.mapMaybe anns $ \ann ->
- [r
- | let r = ExactPrint.Types.annsDP ann >>= \case
+ [ r
+ | let annDPs = ExactPrint.Types.annsDP ann >>= \case
(ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)]
_ -> []
+ , let following = ExactPrint.Types.annFollowingComments ann
+ , let r = following ++ annDPs
, not (null r)
]