Improve module layouting in two aspects

- IEThingWith in export list can now be single-line - Now respect offset of the "module" keyword (retain empty lines after pragmas, for example)
2018-03-12 16:29:47 +01:00 · 2018-03-12 16:29:47 +01:00 · 9531edb2a7
parent 20f9c009ee
commit 9531edb2a7
10 changed files with 131 additions and 59 deletions
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@ -625,6 +625,15 @@ module Main (module Main) where
 #test export-with-things
 module Main (Test(Test, a, b)) where

+#test export-with-things-comment
+-- comment1
+
+module Main
+  ( Test(Test, a, b)
+  , foo -- comment2
+  ) -- comment3
+where
+
 #test export-with-empty-thing
 module Main (Test()) where

--- a/src/Language/Haskell/Brittany/Internal.hs
+++ b/src/Language/Haskell/Brittany/Internal.hs
@ -16,7 +16,7 @@ where
 #include "prelude.inc"

 import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers

 import           Data.Data
@ -133,7 +133,7 @@ parsePrintModule configRaw inputText = runExceptT $ do
 -- can occur.
 pPrintModule
  :: Config
-  -> ExactPrint.Types.Anns
+  -> ExactPrint.Anns
  -> GHC.ParsedSource
  -> ([BrittanyError], TextL.Text)
 pPrintModule conf anns parsedModule =
@ -169,7 +169,7 @@ pPrintModule conf anns parsedModule =
 -- if it does not.
 pPrintModuleAndCheck
  :: Config
-  -> ExactPrint.Types.Anns
+  -> ExactPrint.Anns
  -> GHC.ParsedSource
  -> IO ([BrittanyError], TextL.Text)
 pPrintModuleAndCheck conf anns parsedModule = do
@ -253,7 +253,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
  post <- ppPreamble lmod
  decls `forM_` \decl -> do
    filteredAnns <- mAsk <&> \annMap ->
-      Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap
+      Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap

    traceIfDumpConf "bridoc annotations filtered/transformed"
                    _dconf_dump_annotations
@ -266,26 +266,26 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
      ppDecl decl
  let finalComments = filter
        ( fst .> \case
-          ExactPrint.Types.AnnComment{} -> True
+          ExactPrint.AnnComment{} -> True
          _                             -> False
        )
        post
  post `forM_` \case
-    (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
+    (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
      ppmMoveToExactLoc l
      mTell $ Text.Builder.fromString cmStr
-    (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) ->
+    (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
      let
-        folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of
-          ExactPrint.Types.AnnComment cm
-            | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm
-            -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
-               , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
+        folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
+          ExactPrint.AnnComment cm
+            | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm
+            -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
+               , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
               )
-          _ -> (acc + x, y)
-        (cmX, cmY) = foldl' folder (0, 0) finalComments
+          _ -> (acc + y, x)
+        (cmY, cmX) = foldl' folder (0, 0) finalComments
      in
-        ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY)
+        ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
    _ -> return ()

 withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal ()
@ -323,23 +323,23 @@ ppDecl d@(L loc decl) = case decl of
 -- Prints the information associated with the module annotation
 -- This includes the imports
 ppPreamble :: GenLocated SrcSpan (HsModule RdrName)
-           -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)]
+           -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]
 ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do
  filteredAnns <- mAsk <&> \annMap ->
-    Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap
+    Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap
    -- Since ghc-exactprint adds annotations following (implicit)
    -- modules to both HsModule and the elements in the module
    -- this can cause duplication of comments. So strip
    -- attached annotations that come after the module's where
    -- from the module node
  let (filteredAnns', post) =
-        case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of
+        case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of
          Nothing -> (filteredAnns, [])
          Just mAnn ->
-            let modAnnsDp = ExactPrint.Types.annsDP mAnn
-                isWhere (ExactPrint.Types.G AnnWhere) = True
+            let modAnnsDp = ExactPrint.annsDP mAnn
+                isWhere (ExactPrint.G AnnWhere) = True
                isWhere _                             = False
-                isEof (ExactPrint.Types.G AnnEofPos) = True
+                isEof (ExactPrint.G AnnEofPos) = True
                isEof _                              = False
                whereInd    = List.findIndex (isWhere . fst) modAnnsDp
                eofInd      = List.findIndex (isEof . fst) modAnnsDp
@ -348,8 +348,22 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do
                  (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
                  (Nothing, Just _i) -> ([], modAnnsDp)
                  (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp
-                mAnn'       = mAnn { ExactPrint.Types.annsDP = pre }
-                filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns
+                findInitialCommentSize = \case
+                  ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) ->
+                    let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm
+                    in   y
+                       + GHC.srcSpanEndLine span
+                       - GHC.srcSpanStartLine span
+                       + findInitialCommentSize rest
+                  _ -> 0
+                initialCommentSize = findInitialCommentSize pre
+                fixAbsoluteModuleDP = \case
+                  (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) ->
+                    (g, ExactPrint.DP (y - initialCommentSize, x))
+                  x -> x
+                pre' = map fixAbsoluteModuleDP pre
+                mAnn'       = mAnn { ExactPrint.annsDP = pre' }
+                filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
            in (filteredAnns'', post')
    in do
      traceIfDumpConf "bridoc annotations filtered/transformed"
@ -415,7 +429,7 @@ layoutBriDoc briDoc = do
    -- simpl <- mGet <&> transformToSimple
    -- return simpl

-  anns :: ExactPrint.Types.Anns <- mAsk
+  anns :: ExactPrint.Anns <- mAsk

  let state = LayoutState
        { _lstate_baseYs           = [0]
--- a/src/Language/Haskell/Brittany/Internal/Backend.hs
+++ b/src/Language/Haskell/Brittany/Internal/Backend.hs
@ -250,6 +250,23 @@ layoutBriDocM = \case
            -- layoutMoveToIndentCol y
            layoutWriteAppendMultiline $ Text.pack $ comment
      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
+  BDMoveToKWDP annKey keyword bd -> do
+    mDP <- do
+      state <- mGet
+      let m    = _lstate_comments state
+      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
+      let relevant = [ dp
+                     | Just ann <- [mAnn]
+                     , (ExactPrint.Types.G kw1, dp) <- ann
+                     , keyword == kw1
+                     ]
+      pure $ case relevant of
+        [] -> Nothing
+        (dp:_) -> Just dp
+    case mDP of
+      Nothing                           -> pure ()
+      Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x
+    layoutBriDocM bd
  BDNonBottomSpacing bd -> layoutBriDocM bd
  BDSetParSpacing    bd -> layoutBriDocM bd
  BDForceParSpacing  bd -> layoutBriDocM bd
@ -282,6 +299,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
    BDAnnotationPrior _ bd  -> rec bd
    BDAnnotationKW _ _ bd   -> rec bd
    BDAnnotationRest _ bd   -> rec bd
+    BDMoveToKWDP _ _ bd     -> rec bd
    BDLines ls@(_:_)        -> do
      x <- StateS.get
      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
@ -317,6 +335,7 @@ briDocIsMultiLine briDoc = rec briDoc
    BDAnnotationPrior _ bd  -> rec bd
    BDAnnotationKW _ _ bd   -> rec bd
    BDAnnotationRest _ bd   -> rec bd
+    BDMoveToKWDP _ _ bd     -> rec bd
    BDLines (_:_:_)         -> True
    BDLines [_    ]         -> False
    BDLines []              -> error "briDocIsMultiLine BDLines []"
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@ -16,6 +16,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
  , docSeq
  , docPar
  , docNodeAnnKW
+  , docNodeMoveToKWDP
  , docWrapNode
  , docWrapNodePrior
  , docWrapNodeRest
@ -29,6 +30,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
  , docAnnotationPrior
  , docAnnotationKW
  , docAnnotationRest
+  , docMoveToKWDP
  , docNonBottomSpacing
  , docSetParSpacing
  , docForceParSpacing
@ -441,6 +443,13 @@ docAnnotationKW
  -> ToBriDocM BriDocNumbered
 docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm

+docMoveToKWDP
+  :: AnnKey
+  -> AnnKeywordId
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm
+
 docAnnotationRest
  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
 docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
@ -481,6 +490,15 @@ docNodeAnnKW
 docNodeAnnKW ast kw bdm =
  docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm

+docNodeMoveToKWDP
+  :: Data.Data.Data ast
+  => Located ast
+  -> AnnKeywordId
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+docNodeMoveToKWDP ast kw bdm =
+  docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm
+
 class DocWrapable a where
  docWrapNode :: ( Data.Data.Data ast)
              => Located ast
--- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs
@ -117,8 +117,8 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do
 -- () -- no comments
 -- ( -- a comment
 -- )
-layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered
-layoutLLIEs llies = do
+layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered
+layoutLLIEs enableSingleline llies = do
  ieDs        <- layoutAnnAndSepLLIEs llies
  hasComments <- hasAnyCommentsBelow llies
  case ieDs of
@ -130,7 +130,7 @@ layoutLLIEs llies = do
        )
      ]
    (ieDsH:ieDsT) -> docAltFilter
-      [ ( not hasComments
+      [ ( not hasComments && enableSingleline
        , docSeq
        $  [docLit (Text.pack "(")]
        ++ (docForceSingleline <$> ieDs)
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs
@ -84,7 +84,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
        Just (_, llies) -> do
          hasComments <- hasAnyCommentsBelow llies
          if compact
-          then docSeq [hidDoc, layoutLLIEs llies]
+          then docSeq [hidDoc, layoutLLIEs True llies]
          else do
            ieDs <- layoutAnnAndSepLLIEs llies
            docWrapNodeRest llies $ case ieDs of
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs
@ -24,35 +24,37 @@ import           Language.Haskell.Brittany.Internal.Utils


 layoutModule :: ToBriDoc HsModule
-layoutModule lmod@(L _ mod') =
-  case mod' of
+layoutModule lmod@(L _ mod') = case mod' of
    -- Implicit module Main
-    HsModule Nothing  _   imports _ _ _ -> docLines $ map layoutImport imports
-    HsModule (Just n) les imports _ _ _ -> do
-      let tn         = Text.pack $ moduleNameString $ unLoc n
-          exportsDoc = maybe docEmpty layoutLLIEs les
-      docLines
-        $ docSeq
-            [ docWrapNode lmod docEmpty
-               -- A pseudo node that serves merely to force documentation
-               -- before the node
-            , docAlt
-              (  [ docForceSingleline $ docSeq
-                     [ appSep $ docLit $ Text.pack "module"
-                     , appSep $ docLit tn
-                     , appSep exportsDoc
-                     , docLit $ Text.pack "where"
-                     ]
-                 ]
-              ++ [ docLines
-                     [ docAddBaseY BrIndentRegular $ docPar
-                       ( docSeq
-                         [appSep $ docLit $ Text.pack "module", docLit tn]
-                       )
-                       (docForceMultiline exportsDoc)
-                     , docLit $ Text.pack "where"
-                     ]
-                 ]
-              )
-            ]
-        : map layoutImport imports
+  HsModule Nothing  _   imports _ _ _ -> docLines $ map layoutImport imports
+  HsModule (Just n) les imports _ _ _ -> do
+    let tn = Text.pack $ moduleNameString $ unLoc n
+    docLines
+      $ docSeq
+          [ docNodeAnnKW lmod Nothing docEmpty
+             -- A pseudo node that serves merely to force documentation
+             -- before the node
+          , docNodeMoveToKWDP lmod AnnModule $ docAlt
+            (  [ docForceSingleline $ docSeq
+                   [ appSep $ docLit $ Text.pack "module"
+                   , appSep $ docLit tn
+                   , docWrapNode lmod $ appSep $ case les of
+                     Nothing -> docEmpty
+                     Just x  -> layoutLLIEs True x
+                   , docLit $ Text.pack "where"
+                   ]
+               ]
+            ++ [ docLines
+                   [ docAddBaseY BrIndentRegular $ docPar
+                     (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]
+                     )
+                     (docWrapNode lmod $ case les of
+                       Nothing -> docEmpty
+                       Just x  -> layoutLLIEs False x
+                     )
+                   , docLit $ Text.pack "where"
+                   ]
+               ]
+            )
+          ]
+      : map layoutImport imports
--- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
+++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
@ -301,6 +301,8 @@ transformAlts briDoc =
          reWrap . BDFAnnotationRest annKey <$> rec bd
        BDFAnnotationKW annKey kw bd ->
          reWrap . BDFAnnotationKW annKey kw <$> rec bd
+        BDFMoveToKWDP annKey kw bd ->
+          reWrap . BDFMoveToKWDP annKey kw <$> rec bd
        BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
        BDFLines (l:lr) -> do
          ind <- _acp_indent <$> mGet
@ -460,6 +462,7 @@ getSpacing !bridoc = rec bridoc
      BDFAnnotationPrior _annKey bd -> rec bd
      BDFAnnotationKW _annKey _kw bd -> rec bd
      BDFAnnotationRest  _annKey bd -> rec bd
+      BDFMoveToKWDP _annKey _kw bd -> rec bd
      BDFLines [] -> return
        $ LineModeValid
        $ VerticalSpacing 0 VerticalSpacingParNone False
@ -705,6 +708,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
        BDFAnnotationPrior _annKey bd -> rec bd
        BDFAnnotationKW _annKey _kw bd -> rec bd
        BDFAnnotationRest  _annKey bd -> rec bd
+        BDFMoveToKWDP _annKey _kw bd -> rec bd
        BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
        BDFLines ls@(_:_) -> do
          -- we simply assume that lines is only used "properly", i.e. in
--- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
+++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
@ -128,6 +128,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
  BDAnnotationPrior{} -> Nothing
  BDAnnotationKW{}    -> Nothing
  BDAnnotationRest{}  -> Nothing
+  BDMoveToKWDP{}      -> Nothing
  BDEnsureIndent{}    -> Nothing
  BDSetParSpacing{}   -> Nothing
  BDForceParSpacing{} -> Nothing
--- a/src/Language/Haskell/Brittany/Internal/Types.hs
+++ b/src/Language/Haskell/Brittany/Internal/Types.hs
@ -233,6 +233,7 @@ data BriDoc
  | BDAnnotationPrior AnnKey BriDoc
  | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
  | BDAnnotationRest  AnnKey BriDoc
+  | BDMoveToKWDP AnnKey AnnKeywordId BriDoc
  | BDLines [BriDoc]
  | BDEnsureIndent BrIndent BriDoc
  -- the following constructors are only relevant for the alt transformation
@ -278,6 +279,7 @@ data BriDocF f
  | BDFAnnotationPrior AnnKey (f (BriDocF f))
  | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))
  | BDFAnnotationRest  AnnKey (f (BriDocF f))
+  | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f))
  | BDFLines [(f (BriDocF f))]
  | BDFEnsureIndent BrIndent (f (BriDocF f))
  | BDFForceMultiline (f (BriDocF f))
@ -311,6 +313,7 @@ instance Uniplate.Uniplate BriDoc where
  uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
  uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
  uniplate (BDAnnotationRest annKey bd)  = plate BDAnnotationRest |- annKey |* bd
+  uniplate (BDMoveToKWDP annKey kw bd)   = plate BDMoveToKWDP |- annKey |- kw |* bd
  uniplate (BDLines lines)               = plate BDLines ||* lines
  uniplate (BDEnsureIndent ind bd)       = plate BDEnsureIndent |- ind |* bd
  uniplate (BDForceMultiline   bd)       = plate BDForceMultiline |* bd
@ -342,6 +345,7 @@ unwrapBriDocNumbered tpl = case snd tpl of
  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
  BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
  BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd
+  BDFMoveToKWDP annKey kw bd   -> BDMoveToKWDP annKey kw $ rec bd
  BDFLines lines               -> BDLines $ rec <$> lines
  BDFEnsureIndent ind bd       -> BDEnsureIndent ind $ rec bd
  BDFForceMultiline   bd       -> BDForceMultiline $ rec bd
@ -377,6 +381,7 @@ briDocSeqSpine = \case
  BDAnnotationPrior _annKey bd  -> briDocSeqSpine bd
  BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
  BDAnnotationRest _annKey bd   -> briDocSeqSpine bd
+  BDMoveToKWDP _annKey _kw bd   -> briDocSeqSpine bd
  BDLines lines                 -> foldl' (\(!()) -> briDocSeqSpine) () lines
  BDEnsureIndent _ind bd        -> briDocSeqSpine bd
  BDForceMultiline   bd         -> briDocSeqSpine bd