Deal with module level comments before the first import/decl

For after we have reworked the top level comments to only attach
immediately-preceding ones to a decl

src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs

@@ -45,6 +45,7 @@ import GHC.Types.ForeignCall
 import GHC.Types.Name.Reader
 import GHC.Types.PkgQual
 import GHC.Types.SourceText
+import GHC.Types.SrcLoc
 import GHC.Types.Var
 import GHC.Unit.Module.Warnings
 import GHC.Utils.Misc
@@ -1707,16 +1708,10 @@ instance ExactPrint (HsModule GhcPs) where
         _ -> return lo
 
     am_decls' <- markTrailing (am_decls $ anns an0)
-    imports' <- markTopLevelList imports
-
-    case lo of
-        EpExplicitBraces _ _ -> return ()
-        _ -> do
-          -- Get rid of the balance of the preceding comments before starting on the decls
-          flushComments []
-          putUnallocatedComments []
 
-    decls' <- markTopLevelList (filter notDocDecl decls)
+    mid <- markAnnotated (HsModuleImpDecls (am_cs $ anns an0) imports decls)
+    let imports' = id_imps mid
+    let decls' = id_decls mid
 
     lo1 <- case lo0 of
         EpExplicitBraces open close -> do
@@ -1731,13 +1726,35 @@ instance ExactPrint (HsModule GhcPs) where
         debugM $ "am_eof:" ++ showGhc (pos, prior)
         setEofPos (Just (pos, prior))
 
-    let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
+    let anf = an0 { anns = (anns an0) { am_decls = am_decls', am_cs = [] }}
     debugM $ "HsModule, anf=" ++ showAst anf
 
     return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls')
 
 -- ---------------------------------------------------------------------
 
+-- | This is used to ensure the comments are updated into the right
+-- place for makeDeltaAst.
+data HsModuleImpDecls
+    = HsModuleImpDecls {
+        id_cs     :: [LEpaComment],
+        id_imps   :: [LImportDecl GhcPs],
+        id_decls  :: [LHsDecl GhcPs]
+    } deriving Data
+
+instance ExactPrint HsModuleImpDecls where
+  -- Use an UnHelpfulSpan for the anchor, we are only interested in the comments
+  getAnnotationEntry mid = mkEntry (EpaSpan (UnhelpfulSpan UnhelpfulNoLocationInfo)) [] (EpaComments (id_cs mid))
+  setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs }
+     `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs)
+  exact (HsModuleImpDecls cs imports decls) = do
+    imports' <- markTopLevelList imports
+    decls' <- markTopLevelList (filter notDocDecl decls)
+    return (HsModuleImpDecls cs imports' decls')
+
+
+-- ---------------------------------------------------------------------
+
 instance ExactPrint ModuleName where
   getAnnotationEntry _ = NoEntryVal
   setAnnotationAnchor n _anc _ cs = n

src/Language/Haskell/GHC/ExactPrint/Utils.hs

@@ -305,6 +305,8 @@ workInComments ocs new = cs'
 insertTopLevelCppComments ::  HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment])
 insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs
   = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3)
+    -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs))
+    `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs))
   where
     -- Comments at the top level.
     (an0, cs0) =
@@ -352,12 +354,20 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
 
                                _ -> ([], cs0b)
                            (exports', cse) = allocPreceding exports cs0b'
-    (imports', cs2) = allocPreceding imports cs1
+    (imports0, cs2) = allocPreceding imports cs1
+    (imports', hc0i) = balanceFirstLocatedAComments imports0
 
     (decls0, cs3) = allocPreceding decls cs2
-    (decls', hc0) = balanceFirstDeclComments decls0
-    hc1 = workInComments (comments an3) hc0
-    an4 = an3 { comments = hc1 }
+    (decls', hc0d) = balanceFirstLocatedAComments decls0
+
+    -- Either hc0i or hc0d should have comments. Combine them
+    hc0 = hc0i ++ hc0d
+
+    (hc1,hc_cs) = if null ( am_main $ anns an3)
+        then (hc0,[])
+        else splitOnWhere (am_main $ anns an3)  hc0
+    hc2 = workInComments (comments an3) hc1
+    an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 }
 
     allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment])
     allocPreceding [] cs' = ([], cs')
@@ -371,13 +381,21 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
         cs4' = workInComments cs4 these
         (xs',rest') = allocPreceding xs rest
 
-balanceFirstDeclComments :: [LHsDecl GhcPs] -> ([LHsDecl GhcPs], [LEpaComment])
-balanceFirstDeclComments [] = ([],[])
-balanceFirstDeclComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd0) a:ds, hc')
+splitOnWhere :: [AddEpAnn] -> [LEpaComment] -> ([LEpaComment], [LEpaComment])
+splitOnWhere [] csIn = (csIn,[])
+splitOnWhere (AddEpAnn AnnWhere (EpaSpan (RealSrcSpan s _)):_) csIn = (hc, fc)
+  where
+    (hc,fc) = break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) ) csIn
+splitOnWhere (AddEpAnn AnnWhere _:_) csIn = (csIn, [])
+splitOnWhere (_:as) csIn = splitOnWhere as csIn
+
+balanceFirstLocatedAComments :: [LocatedA a] -> ([LocatedA a], [LEpaComment])
+balanceFirstLocatedAComments [] = ([],[])
+balanceFirstLocatedAComments ((L (EpAnn anc an csd) a):ds) = (L (EpAnn anc an csd0) a:ds, hc')
   where
     (csd0, hc') = case anc of
         EpaSpan (RealSrcSpan s _) -> (csd', hc)
-               `debug` ("balanceFirstDeclComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header))
+               `debug` ("balanceFirstLocatedAComments: (csd,csd',attached,header)=" ++ showAst (csd,csd',attached,header))
           where
             (priors, inners) =  break (\(L ll _) -> (ss2pos $ anchor ll) > (ss2pos s) )
                                        (priorComments csd)

tests/Test.hs

@@ -139,14 +139,14 @@ mkTests = do
   roundTripMakeDeltaTests <- findTestsMD libdir
   -- prettyRoundTripTests <- findPrettyTests libdir
   return $ TestList [
-                   --    internalTests,
-                   --    roundTripTests
-                   -- ,
-                   --   (transformTests libdir)
-                   -- , (failingTests libdir)
-                   -- ,
-                   --   roundTripBalanceCommentsTests
-                   -- ,
+                      internalTests,
+                      roundTripTests
+                   ,
+                     (transformTests libdir)
+                   , (failingTests libdir)
+                   ,
+                     roundTripBalanceCommentsTests
+                   ,
                      roundTripMakeDeltaTests
                     ]
 
@@ -203,7 +203,13 @@ tt' = do
 
     -- mkParserTest libdir "ghc98" "ModuleComments1.hs"
     -- mkParserTestBC libdir "ghc98" "MonoidsFD1.hs"
-    mkParserTestMD libdir "ghc98" "ModuleComments1.hs"
+    -- mkParserTestMD libdir "ghc98" "ModuleComments1.hs"
+
+    -- mkParserTest libdir "ghc98" "ModuleComments2.hs"
+    -- mkParserTestMD libdir "ghc98" "ModuleComments2.hs"
+
+    -- mkParserTest libdir "ghc98" "ModuleComments3.hs"
+    mkParserTestMD libdir "ghc98" "ModuleComments3.hs"
 
 
     -- mkParserTest libdir "ghc80" "ForFree.hs"

tests/examples/ghc710/CExpected1.hs

@@ -0,0 +1,4 @@
+module CExpected where
+-- Comment
+
+foo x = 1

tests/examples/ghc710/EmptyMostlyTrailing.hs

@@ -0,0 +1,8 @@
+-- top of module
+module EmptyMostlyTrailing where
+-- after module header
+   {
+x = 1
+-- comment
+   }
+-- really trailing

tests/examples/ghc92/TopLevelSemis4.hs

@@ -0,0 +1,12 @@
+module TopLevelSemis4 where
+
+data Foo = Foo
+
+-- After Foo
+;
+-- After Foo semi
+
+data Bar = Bar
+
+-- After Bar
+;

tests/examples/ghc94/Haddock3.hs

@@ -0,0 +1,13 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-}
+module Haddock3 (
+
+        f
+
+        {-| nested-style doc comments -}
+        , g
+
+   ) where
+
+f = undefined
+g = undefined
+

tests/examples/ghc98/ModuleComments2.hs

@@ -0,0 +1,15 @@
+-- top of module
+module {- c1 -} ModuleComments1 {- c2 -}
+    -- c3
+    (
+    -- c4
+    foo
+    -- c5
+    ) {- c6 -} where {- c7 -}
+-- c8
+import Data.Text
+-- c9
+
+foo = x
+
+-- eof

tests/examples/ghc98/ModuleComments3.hs

@@ -0,0 +1,25 @@
+-- top of module
+module {- c1 -} ModuleComments1 {- c2 -}
+    -- c3
+    (
+    -- c4
+    foo
+    -- c5
+    ) {- c6 -} where {- c7 -}
+{
+-- c8
+;
+-- c9
+
+-- c10
+import Data.Text
+-- c11
+;
+
+-- c12
+foo = x
+-- c13
+;
+-- c14
+}
+-- eof

tests/examples/ghc98/MonoidsFD1.hs

@@ -0,0 +1,7 @@
+
+module Main where
+
+-- comment
+
+x = 1
+