ghc-exactprint 1.4.1 → 1.5.0

raw patch · 15 files changed

+482/−209 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog +6/−0
• ghc-exactprint.cabal +2/−1
• src/Language/Haskell/GHC/ExactPrint.hs +9/−0
• src/Language/Haskell/GHC/ExactPrint/Dump.hs +307/−0
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +63/−141
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +40/−46
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +12/−14
• tests/Test.hs +14/−3
• tests/Test/Common.hs +1/−0
• tests/Test/NoAnnotations.hs +1/−0
• tests/Test/Transform.hs +5/−4
• tests/examples/ghc92/Async.hs +11/−0
• tests/examples/ghc92/Foo.hs +7/−0
• tests/examples/ghc92/Foo2.hs +4/−0
• tests/examples/transform/RmDecl4.hs.expected +0/−0

@@ -1,3 +1,9 @@+2022-02-01 v1.5.0+	* Add private version of showAstData, to be able to render+	AnchorOperation's hacked into SrcSpan's.+	* Change the starting top level margin from 0 to 1. This means we+	can use (DifferentLine n 0) everywhere with the same meaning, not+	needing (DifferentLine n 1) at the top level. Hence 1.5 bump. 2022-01-03 v1.4.1 	* Fix delta-in of open/close parentheses in AnnContext (@pepeiborra) 2022-01-03 v1.4.0.1

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             1.4.1+version:             1.5.0 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 9.2.1, this                      library provides a means to round trip any code that can@@ -55,6 +55,7 @@  library   exposed-modules:     Language.Haskell.GHC.ExactPrint+                     , Language.Haskell.GHC.ExactPrint.Dump                      , Language.Haskell.GHC.ExactPrint.ExactPrint                      , Language.Haskell.GHC.ExactPrint.Lookup                      , Language.Haskell.GHC.ExactPrint.Orphans

@@ -16,8 +16,17 @@          -- * Relativising         , makeDeltaAst+++        -- * Dumping ASTs+        , showAst+        -- ** Temporary copy from GHC, shows AnchorOps embedded in SrcSpan+        , showAstData+        , BlankSrcSpan(..)+        , BlankEpAnnotations(..)         ) where +import Language.Haskell.GHC.ExactPrint.Dump import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types

@@ -0,0 +1,307 @@++{-+Temporary copy of the GHC.Hs.Dump module, modified to show DeltaPos+hacked into a SrcSpan.+-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Haskell.GHC.ExactPrint.Dump (+        -- * Dumping ASTs+        showAstData,+        BlankSrcSpan(..),+        BlankEpAnnotations(..),+    ) where++import Prelude ()+import GHC.Prelude++import GHC.Hs hiding ( ann, anns, deltaPos, realSrcSpan )++import GHC.Core.DataCon++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Types.Name.Set+import GHC.Types.Name hiding ( occName )+import GHC.Types.SrcLoc+import GHC.Types.Var+import GHC.Types.SourceText+import GHC.Unit.Module hiding ( moduleName )+import GHC.Utils.Outputable++import Data.Data hiding (Fixity)+import qualified Data.ByteString as B++import Data.Generics (extQ, ext1Q, ext2Q)+import Language.Haskell.GHC.ExactPrint.Utils++data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan+                  deriving (Eq,Show)++data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations+                  deriving (Eq,Show)++-- | Show a GHC syntax tree. This parameterised because it is also used for+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked+-- out, to avoid comparing locations, only structure+showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc+showAstData bs ba a0 = blankLine $$ showAstData' a0+  where+    showAstData' :: Data a => a -> SDoc+    showAstData' =+      generic+              `ext1Q` list+              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan+              `extQ` annotation+              `extQ` annotationModule+              `extQ` annotationAddEpAnn+              `extQ` annotationGrhsAnn+              `extQ` annotationEpAnnHsCase+              `extQ` annotationEpAnnHsLet+              `extQ` annotationAnnList+              `extQ` annotationEpAnnImportDecl+              `extQ` annotationAnnParen+              `extQ` annotationTrailingAnn+              `extQ` annotationEpaLocation+              `extQ` addEpAnn+              `extQ` lit `extQ` litr `extQ` litt+              `extQ` sourceText+              `extQ` deltaPos+              `extQ` epaAnchor+              `extQ` bytestring+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var+              `extQ` dataCon+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+              `extQ` fixity+              `ext2Q` located+              `extQ` srcSpanAnnA+              `extQ` srcSpanAnnL+              `extQ` srcSpanAnnP+              `extQ` srcSpanAnnC+              `extQ` srcSpanAnnN++      where generic :: Data a => a -> SDoc+            generic t = parens $ text (showConstr (toConstr t))+                                  $$ vcat (gmapQ showAstData' t)++            string :: String -> SDoc+            string     = text . normalize_newlines . show++            fastString :: FastString -> SDoc+            fastString s = braces $+                            text "FastString:"+                        <+> text (normalize_newlines . show $ s)++            bytestring :: B.ByteString -> SDoc+            bytestring = text . normalize_newlines . show++            list []    = brackets empty+            list [x]   = brackets (showAstData' x)+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)+                                $$ go x2 xs+              where+                go y [] = text "," <> showAstData' y <> text "]"+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys++            -- Eliminate word-size dependence+            lit :: HsLit GhcPs -> SDoc+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            lit l                  = generic l++            litr :: HsLit GhcRn -> SDoc+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litr l                  = generic l++            litt :: HsLit GhcTc -> SDoc+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litt l                  = generic l++            numericLit :: String -> Integer -> SourceText -> SDoc+            numericLit tag x s = braces $ hsep [ text tag+                                               , generic x+                                               , generic s ]++            sourceText :: SourceText -> SDoc+            sourceText NoSourceText = parens $ text "NoSourceText"+            sourceText (SourceText src) = case bs of+              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src+              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src+              _                -> parens $ text "SourceText" <+> text "blanked"++            epaAnchor :: EpaLocation -> SDoc+            epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r+            epaAnchor (EpaDelta d cs) = case ba of+              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs+              BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"++            deltaPos :: DeltaPos -> SDoc+            deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c+            deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c++            name :: Name -> SDoc+            name nm    = braces $ text "Name:" <+> ppr nm++            occName n  =  braces $+                          text "OccName:"+                      <+> text (occNameString n)++            moduleName :: ModuleName -> SDoc+            moduleName m = braces $ text "ModuleName:" <+> ppr m++            srcSpan :: SrcSpan -> SDoc+            srcSpan ss = case bs of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <>+                             (hang (pprSrcSpanWithAnchor ss) 1+                                   (text ""))+             BlankSrcSpanFile -> braces $ char ' ' <>+                             (hang (pprUserSpan False ss) 1+                                   (text ""))++            realSrcSpan :: RealSrcSpan -> SDoc+            realSrcSpan ss = case bs of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <>+                             (hang (ppr ss) 1+                                   (text ""))+             BlankSrcSpanFile -> braces $ char ' ' <>+                             (hang (pprUserRealSpan False ss) 1+                                   (text ""))+++            addEpAnn :: AddEpAnn -> SDoc+            addEpAnn (AddEpAnn a s) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "AddEpAnn"+             NoBlankEpAnnotations ->+              parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s++            var  :: Var -> SDoc+            var v      = braces $ text "Var:" <+> ppr v++            dataCon :: DataCon -> SDoc+            dataCon c  = braces $ text "DataCon:" <+> ppr c++            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc+            bagRdrName bg =  braces $+                             text "Bag(LocatedA (HsBind GhcPs)):"+                          $$ (list . bagToList $ bg)++            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc+            bagName bg  =  braces $+                           text "Bag(LocatedA (HsBind Name)):"+                        $$ (list . bagToList $ bg)++            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc+            bagVar bg  =  braces $+                          text "Bag(LocatedA (HsBind Var)):"+                       $$ (list . bagToList $ bg)++            nameSet ns =  braces $+                          text "NameSet:"+                       $$ (list . nameSetElemsStable $ ns)++            fixity :: Fixity -> SDoc+            fixity fx =  braces $+                         text "Fixity:"+                     <+> ppr fx++            located :: (Data a, Data b) => GenLocated a b -> SDoc+            located (L ss a)+              = parens (text "L"+                        $$ vcat [showAstData' ss, showAstData' a])+++            -- -------------------------++            annotation :: EpAnn [AddEpAnn] -> SDoc+            annotation = annotation' (text "EpAnn [AddEpAnn]")++            annotationModule :: EpAnn AnnsModule -> SDoc+            annotationModule = annotation' (text "EpAnn AnnsModule")++            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc+            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")++            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc+            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")++            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc+            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")++            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc+            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")++            annotationAnnList :: EpAnn AnnList -> SDoc+            annotationAnnList = annotation' (text "EpAnn AnnList")++            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")++            annotationAnnParen :: EpAnn AnnParen -> SDoc+            annotationAnnParen = annotation' (text "EpAnn AnnParen")++            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc+            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")++            annotationEpaLocation :: EpAnn EpaLocation -> SDoc+            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")++            annotation' :: forall a .(Data a)+                       => SDoc -> EpAnn a -> SDoc+            annotation' tag anns = case ba of+             BlankEpAnnotations -> parens (text "blanked:" <+> tag)+             NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))+                                               $$ vcat (gmapQ showAstData' anns)++            -- -------------------------++            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")++            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")++            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")++            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")++            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")++            locatedAnn'' :: forall a. (Data a)+              => SDoc -> SrcSpanAnn' a -> SDoc+            locatedAnn'' tag ss = parens $+              case cast ss of+                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                  case ba of+                    BlankEpAnnotations+                      -> parens (text "blanked:" <+> tag)+                    NoBlankEpAnnotations+                      -> text "SrcSpanAnn" <+> showAstData' ann+                              <+> srcSpan s+                Nothing -> text "locatedAnn:unmatched" <+> tag+                           <+> (parens $ text (showConstr (toConstr ss)))+++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs)                 = x:normalize_newlines xs+normalize_newlines []                     = []++pprSrcSpanWithAnchor :: SrcSpan -> SDoc+pprSrcSpanWithAnchor ss@(UnhelpfulSpan _) = ppr ss+pprSrcSpanWithAnchor ss = ppr ss <+> parens (ppr (hackSrcSpanToAnchor ss))

@@ -24,10 +24,13 @@   , stringOptions   , epOptions   , deltaOptions++  -- Temporary to avoid import loop problems+  , showAst   ) where  import GHC-import GHC.Base (NonEmpty(..))+import GHC.Base (NonEmpty(..) ) import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF@@ -57,6 +60,7 @@  import Data.Void +import Language.Haskell.GHC.ExactPrint.Dump import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Types@@ -65,6 +69,15 @@  -- --------------------------------------------------------------------- +-- Note: moved from Language.Haskell.GHC.ExactPrint.Utils as a hack to+-- avoid import loop problems while we have to use the local version+-- of Dump+showAst :: (Data a) => a -> String+showAst ast+  = showSDocUnsafe+    $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast+-- ---------------------------------------------------------------------+ exactPrint :: ExactPrint ast => ast -> String exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) @@ -99,9 +112,9 @@ defaultEPState :: EPState defaultEPState = EPState              { epPos      = (1,1)-             , dLHS       = 0+             , dLHS       = 1              , pMarkLayout = False-             , pLHS = 0+             , pLHS = 1              , dMarkLayout = False              , dPriorEndPosition = (1,1)              , uAnchorSpan = badRealSrcSpan@@ -192,11 +205,6 @@  -- --------------------------------------------------------------------- --- type Annotated = FreeT AnnotationF Identity--- type Annotated a = EP w m a---- ---------------------------------------------------------------------- -- | Key entry point.  Switches to an independent AST element with its -- own annotation, calculating new offsets, etc markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a@@ -237,7 +245,11 @@ fromAnn' :: (HasEntry a) => a -> Entry fromAnn' an = case fromAnn an of   NoEntryVal -> NoEntryVal-  Entry a c _ u -> Entry a c FlushComments u+  Entry a c _ u -> Entry a c' FlushComments u+    where+      c' = case c of+        EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs)+        EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct  -- --------------------------------------------------------------------- @@ -340,22 +352,18 @@    debugM $ "enterAnn: (anchor_op, curAnchor):" ++ show (anchor_op anchor', rs2range curAnchor)   debugM $ "enterAnn: (dLHS,spanStart,pec,edp)=" ++ show (off,spanStart,priorEndAfterComments,edp)-  p <- getPosP+  p0 <- getPosP   d <- getPriorEndD-  debugM $ "enterAnn: (posp, posd)=" ++ show (p,d)+  debugM $ "enterAnn: (posp, posd)=" ++ show (p0,d)    -- end of delta phase processing   -- -------------------------------------------------------------------   -- start of print phase processing    let mflush = when (flush == FlushComments) $ do-        debugM $ "flushing comments in enterAnn"-        flushComments (getFollowingComments cs)+        debugM $ "flushing comments in enterAnn:" ++ showAst cs+        flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs)) -  -- let-  --   st = annNone-  -- withOffset st (advance edp >> exact a >> mflush)--- local :: (r -> r) -> RWST r w s m a -> RWST r w s m a   advance edp   a' <- exact a   mflush@@ -373,22 +381,13 @@             CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) [])             CanUpdateAnchorOnly -> setAnnotationAnchor a' newAchor emptyComments             NoCanUpdateAnchor -> a'-  -- let r = (setAnnotationAnchor a' newAchor (mkEpaComments [] postCs))-  pure () -- monadic action to flush debugM   -- debugM $ "calling setAnnotationAnchor:(curAnchor, newAchor,priorCs,postCs)=" ++ showAst (show (rs2range curAnchor), newAchor, priorCs, postCs)   -- debugM $ "calling setAnnotationAnchor:(newAchor,postCs)=" ++ showAst (newAchor, postCs)-  debugM $ "enterAnn:done:(p,a) =" ++ show (p, astId a')+  debugM $ "enterAnn:done:(p,a) =" ++ show (p0, astId a')   return r  -- --------------------------------------------------------------------- --- withComments :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a)--- withComments a =---   local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) })----- ---------------------------------------------------------------------- addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () addCommentsA csNew = addComments (map tokComment csNew) @@ -425,12 +424,23 @@ -- ones in the state. flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () flushComments trailing = do-  addCommentsA trailing+  addCommentsA (filterEofComment False trailing)   cs <- getUnallocatedComments   debugM $ "flushing comments starting"   mapM_ printOneComment (sortComments cs)+  debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)+  debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)+  mapM_ printOneComment (map tokComment (filterEofComment True trailing))   debugM $ "flushing comments done" +filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]+filterEofComment keep cs = fixCs cs+  where+      notEof com = case com of+       L _ (GHC.EpaComment (EpaEofComment) _) -> keep+       _ -> not keep+      fixCs c = filter notEof c+ -- ---------------------------------------------------------------------  -- |In order to interleave annotations into the stream, we turn them into@@ -451,29 +461,6 @@       | Set.member k keywords = go ((mkKWComment k ss):cs', ans) ls       | otherwise             = go (cs', (AddEpAnn k ss):ans)    ls ---- -- |In order to interleave annotations into the stream, we turn them into--- -- comments.--- annotationsToComments' :: (Monad m, Monoid w) => [AddEpAnn] -> [AnnKeywordId] -> EP w m ()--- annotationsToComments' ans kws = do---   let---     getSpans _ [] = []---     getSpans k1 (AddEpAnn k2 ss:as)---       | k1 == k2 = ss : getSpans k1 as---       | otherwise = getSpans k1 as---     doOne :: (Monad m, Monoid w) => AnnKeywordId -> EP w m [Comment]---     doOne kw = do---       let sps =getSpans kw ans---       return $ map (mkKWComment kw ) sps---     -- TODO:AZ make sure these are sorted/merged properly when the invariant for---     -- allocateComments is re-established.---   newComments <- mapM doOne kws---   addComments (concat newComments)---- annotationsToCommentsA :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> [AnnKeywordId] -> EP w m ()--- annotationsToCommentsA EpAnnNotUsed _ = return ()--- annotationsToCommentsA an kws = annotationsToComments' (anns an) kws- -- ---------------------------------------------------------------------  -- Temporary function to simply reproduce the "normal" pretty printer output@@ -526,7 +513,6 @@     CaptureComments -> takeAppliedComments     NoCaptureComments -> return []   debugM $ "printStringAtRs:cs'=" ++ show cs'-  -- return (EpaDelta p' (map comment2LEpaComment (noKWComments cs')))   return (EpaDelta p' (map comment2LEpaComment cs'))  printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()@@ -534,11 +520,6 @@  -- --------------------------------------------------------------------- --- AZ:TODO get rid of this-printStringAtMLoc :: (Monad m, Monoid w) => Maybe EpaLocation -> String -> EP w m ()-printStringAtMLoc (Just aa) s = printStringAtAA aa s >> return ()-printStringAtMLoc Nothing s = printStringAtLsDelta (SameLine 1) s >> return ()- printStringAtMLoc' :: (Monad m, Monoid w)   => Maybe EpaLocation -> String -> EP w m (Maybe EpaLocation) printStringAtMLoc' (Just aa) s = Just <$> printStringAtAA aa s@@ -579,16 +560,13 @@   p2 <- getPosP   pe2 <- getPriorEndD   debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2)-  -- setPriorEndASTPD True (p1,p2)   setPriorEndASTPD True (pe1,pe2)   cs' <- case capture of     CaptureComments -> takeAppliedComments     NoCaptureComments -> return []   debugM $ "printStringAtAA:(pe1,pe2,p1,p2,cs')=" ++ show (pe1,pe2,p1,p2,cs')-  -- return (EpaDelta d (map comment2LEpaComment (noKWComments cs')))   return (EpaDelta d (map comment2LEpaComment cs')) - -- ---------------------------------------------------------------------  markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()@@ -597,14 +575,6 @@  -- --------------------------------------------------------------------- --- -- TODO: remove in favour of markLensMAA--- markLocatedMAA :: (Monad m, Monoid w) => EpAnn a -> (a -> Maybe AddEpAnn) -> EP w m ()--- markLocatedMAA EpAnnNotUsed  _  = return ()--- markLocatedMAA (EpAnn _ a _) f =---   case f a of---     Nothing -> return ()---     Just aa -> markAddEpAnn aa >> return ()- markLensMAA :: (Monad m, Monoid w) => EpAnn a -> Lens a (Maybe AddEpAnn) -> EP w m (EpAnn a) markLensMAA EpAnnNotUsed  _  = return EpAnnNotUsed markLensMAA (EpAnn anc a cs) l =@@ -621,17 +591,6 @@   return (EpAnn anc (set l a' a) cs)  --- TODO: removein favour of markEpAnnL-markLocatedAAL :: (Monad m, Monoid w) => EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EP w m Int-markLocatedAAL EpAnnNotUsed  _ _ = return 1-markLocatedAAL (EpAnn _ a _) f kw = go (f a)-  where-    go [] = return 1-    go (aa@(AddEpAnn kw' _):as)-      | kw' == kw = mark [aa] kw-      | otherwise = go as-- markEpAnnLMS :: (Monad m, Monoid w)   => EpAnn a -> Lens a [AddEpAnn] -> AnnKeywordId -> Maybe String -> EP w m (EpAnn a) markEpAnnLMS an l kw Nothing = markEpAnnL an l kw@@ -732,15 +691,6 @@     kw AnnParens       = (AnnOpenP,  AnnCloseP)     kw AnnParensHash   = (AnnOpenPH, AnnClosePH)     kw AnnParensSquare = (AnnOpenS, AnnCloseS)--- markParen' :: (Monad m, Monoid w) => EpAnn AnnParen -> (forall a. (a,a) -> a) -> EP w m (EpAnn AnnParen)--- markParen' EpAnnNotUsed _ = return (EpAnnNotUsed)--- markParen' (EpAnn anc (AnnParen pt o c) cs) f = do---   markKwA (f $ kw pt) (f (o, c))---   return (EpAnn anc (AnnParen pt o c) cs)---   where---     kw AnnParens       = (AnnOpenP,  AnnCloseP)---     kw AnnParensHash   = (AnnOpenPH, AnnClosePH)---     kw AnnParensSquare = (AnnOpenS, AnnCloseS)  -- --------------------------------------------------------------------- -- Bare bones Optics@@ -1133,9 +1083,7 @@ markAnnKwAllL :: (Monad m, Monoid w)   => EpAnn a -> Lens a [EpaLocation] -> AnnKeywordId -> EP w m (EpAnn a) markAnnKwAllL EpAnnNotUsed  _ _  = return EpAnnNotUsed--- markAnnKwAllL (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) markAnnKwAllL (EpAnn anc a cs) l kw = do-  -- anns <- mapM (markKwA kw) (sort (view l a))   anns <- mapM (markKwA kw) (view l a)   return (EpAnn anc (set l anns a) cs) @@ -1157,17 +1105,12 @@   t <- markTrailing (lann_trailing a)   return (EpAnn anc (a { lann_trailing = t }) cs) --- Deprecate in favour of markEpAnnL+-- TODO: Deprecate in favour of markEpAnnL markEpAnn :: (Monad m, Monoid w)   => EpAnn [AddEpAnn] -> AnnKeywordId -> EP w m Int -- Return something to trigger not used warning markEpAnn EpAnnNotUsed _ = return 1 markEpAnn (EpAnn _ a _) kw = mark a kw >> return 1 --- -- Deprecate in favour of markEpAnnL--- markEpAnn' :: (Monad m, Monoid w)---   => EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EP w m ()--- markEpAnn' EpAnnNotUsed _ _ = return ()--- markEpAnn' (EpAnn _anc a _cs) f kw = mark' (f a) kw >> return ()  markEpAnnL :: (Monad m, Monoid w)   => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann)@@ -1324,7 +1267,9 @@   dp' <- case mep of     Just (Anchor _ (MovedAnchor edp)) -> do       debugM $ "printOneComment:edp=" ++ show edp-      adjustDeltaForOffsetM edp+      ddd <- fmap unTweakDelta $ adjustDeltaForOffsetM edp+      debugM $ "printOneComment:ddd=" ++ show ddd+      fmap unTweakDelta $ adjustDeltaForOffsetM edp     _ -> return dp   -- Start of debug printing   -- LayoutStartCol dOff <- getLayoutOffsetD@@ -1334,18 +1279,25 @@   updateAndApplyComment c dp'   printQueuedComment (anchor loc) c dp' +-- | For comment-related deltas starting on a new line we have an+-- off-by-one problem. Adjust+unTweakDelta :: DeltaPos  -> DeltaPos+unTweakDelta (SameLine d) = SameLine d+unTweakDelta (DifferentLine l d) = DifferentLine l (d+1)++ updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()-updateAndApplyComment co@(Comment str anc pp mo) dp = do+updateAndApplyComment (Comment str anc pp mo) dp = do   -- debugM $ "updateAndApplyComment: (dp,anc',co)=" ++ showAst (dp,anc',co)   applyComment (Comment str anc' pp mo)   where-    -- anc' = anc { anchor_op = MovedAnchor dp }     anc' = anc { anchor_op = op}      (r,c) = ss2posEnd pp     la = anchor anc     dp'' = if r == 0-           then (ss2delta (r,c+1) la)+           -- then (ss2delta (r,c+1) la)+           then (ss2delta (r,c+0) la)            else (ss2delta (r,c)   la)     dp' = if pp == anchor anc              then dp@@ -1394,14 +1346,12 @@ -- | Bare Located elements are simply stripped off without further -- processing. instance (ExactPrint a) => ExactPrint (Located a) where-  -- getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments NoFlushComments NoCanUpdateAnchor   getAnnotationEntry (L l _) = case l of     UnhelpfulSpan _ -> NoEntryVal     _ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly-  -- getAnnotationEntry (L l _) = NoEntryVal -  -- setAnnotationAnchor _la _anc _cs = error "should not be called:setAnnotationAnchor (Located a)"-  setAnnotationAnchor (L _ a) anc _cs = L (hackAnchorToSrcSpan anc) a+  setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a)+                 `debug` ("setAnnotationAnchor(Located):" ++ showAst anc)    exact (L l a) = L l <$> markAnnotated a @@ -1457,7 +1407,6 @@            return (an1, Just m', mdeprec', mexports') -    -- debugM $ "After HsModule.AnnWhere done, an0=" ++ showAst (anns an0)     let ann_decls = EpAnn (entry an) (am_decls $ anns an0) emptyComments     (ann_decls', (decls', imports')) <- markAnnList' False ann_decls $ do       imports' <- markTopLevelList imports@@ -1528,7 +1477,7 @@               return $ Just (mo', mc')             Nothing ->  do               _ <- markAnnOpen' Nothing msrc "{-# SOURCE"-              printStringAtMLoc Nothing "#-}"+              printStringAtLsDelta (SameLine 1) "#-}"               return Nothing         NoSourceText -> return (importDeclAnnPragma an)     ann1 <- if safeflag@@ -1880,17 +1829,13 @@       case mtybndrs of         Nothing -> return (an0, Nothing)         Just bndrs -> do-          -- an1 <-  markLensMAA an0 (\a -> fmap fst (ra_tyanns a))  -- AnnForall           an1 <-  markLensMAA an0 lra_tyanns_fst  -- AnnForall           bndrs' <- mapM markAnnotated bndrs-          -- an2 <- markLensMAA an1 (\a -> fmap snd (ra_tyanns a))  -- AnnDot           an2 <- markLensMAA an1 lra_tyanns_snd  -- AnnDot           return (an2, Just bndrs') -    -- an2 <- markLensMAA an1 (\a -> fmap fst (ra_tmanns a))  -- AnnForall     an2 <- markLensMAA an1 lra_tmanns_fst  -- AnnForall     termbndrs' <- mapM markAnnotated termbndrs-    -- an3 <- markLensMAA an2 (\a -> fmap snd (ra_tmanns a))  -- AnnDot     an3 <- markLensMAA an2 lra_tmanns_snd  -- AnnDot      lhs' <- markAnnotated lhs@@ -2058,7 +2003,6 @@  -- --------------------------------------------------------------------- --- instance ExactPrint (LHsTypeArg GhcPs) where instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)      =>  ExactPrint (HsArg tm ty) where   getAnnotationEntry = const NoEntryVal@@ -2082,7 +2026,6 @@                      , cid_datafam_insts = adts })       = do           (an0, mbOverlap', inst_ty') <- top_matter-          -- an0 <- markEpAnnL an' lidl AnnWhere           an1 <- markEpAnnL an0 lidl AnnOpenC           an2 <- markEpAnnAllL an1 lid AnnSemi           ds <- withSortKey sortKey@@ -2394,7 +2337,7 @@     return (HsValBinds an1 valbinds')    exact (HsIPBinds an bs) = do-    (as, ipb) <- markAnnList True an (markLocatedAAL an al_rest AnnWhere+    (as, ipb) <- markAnnList True an (markEpAnnL an lal_rest AnnWhere                            >> markAnnotated bs                            >>= \bs' -> return (HsIPBinds an bs'::HsLocalBinds GhcPs))     case ipb of@@ -2460,7 +2403,6 @@ prepareListAnnotationF an ls = map (\b -> (realSrcSpan $ getLocA b, go b)) ls   where     go (L l a) = do-      -- d' <- markAnnotated (DataFamInstDeclWithContext an TopLevel a)       d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a)       return (toDyn (L l (dc_d d'))) @@ -2698,7 +2640,9 @@    exact (GRHS an guards expr) = do     debugM $ "GRHS comments:" ++ showGhc (comments an)-    an0 <- markLensKwM an lga_vbar AnnVbar+    an0 <- if null guards+             then return an+             else markLensKwM an lga_vbar AnnVbar     guards' <- markAnnotated guards     debugM $ "GRHS before matchSeparator"     an1 <- markLensAA an0 lga_sep -- Mark the matchSeparator for these GRHSs@@ -2825,7 +2769,6 @@                 HsIntegral   (IL src _ _) -> src                 HsFractional (FL { fl_text = src }) -> src                 HsIsString src _          -> src-    -- markExternalSourceText l str ""     case str of       SourceText s -> printStringAdvance s >> return ()       NoSourceText -> withPpr x >> return ()@@ -3177,7 +3120,6 @@   setAnnotationAnchor a _ _ = a   exact (MG x matches o) = do     -- TODO:AZ use SortKey, in MG ann.-    -- matches' <- markAnnotated matches     matches' <- if isGoodSrcSpan (getLocA matches)       then markAnnotated matches       else return matches@@ -3510,7 +3452,6 @@    exact (RecStmt an stmts a b c d e) = do     debugM $ "RecStmt"-    -- markLocatedAAL an al_rest AnnRec     an0 <- markEpAnnL an lal_rest AnnRec     (an1, stmts') <- markAnnList True an0 (markAnnotated stmts)     return (RecStmt an1 stmts' a b c d e)@@ -4098,15 +4039,6 @@                              , deriv_clause_strategy = dcs                              , deriv_clause_tys      = dct' })       where-        -- -- This complexity is to distinguish between-        -- --    deriving Show-        -- --    deriving (Show)-        -- pp_dct [HsIB { hsib_body = ty }]-        --          = ppr (parenthesizeHsType appPrec ty)-        -- pp_dct _ = parens (interpp'SP dct)--        -- @via@ is unique in that in comes /after/ the class being derived,-        -- so we must special-case it.         (exact_strat_before, exact_strat_after) =           case dcs of             Just v@(L _ ViaStrategy{}) -> (pure (), markAnnotated v >> pure ())@@ -4141,10 +4073,8 @@     a' <- markAnnotated a     return (L (SrcSpanAnn EpAnnNotUsed l) a')   exact (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens closes) cs) l) a) = do-    -- mapM_ (markKwA AnnOpenP) (sort opens)     opens' <- mapM (markKwA AnnOpenP) opens     a' <- markAnnotated a-    -- mapM_ (markKwA AnnCloseP) (sort closes)     closes' <- mapM (markKwA AnnCloseP) closes     ma' <- case ma of       Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r@@ -4190,12 +4120,6 @@       case ann of         NameAnn a o l c t -> do           mn <- markName a o (Just (l,n)) c-          -- let (o', (Just (l',_)), c') =-          --       case mn of-          --        (o', (Just (l',n')), c') -> (o', (Just (l',n')), c')-          --        _ -> error "ExactPrint (LocatedN RdrName)"-          -- t' <- markTrailing t-          -- return (NameAnn a o' l' c' t')           case mn of             (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')               t' <- markTrailing t@@ -4539,7 +4463,6 @@     let an = fixAnnListAnn an'     debugM $ "LocatedL [ExprLStmt"     (an'', stmts') <- markAnnList True an $ do-      -- markLocatedMAA an al_open       case snocView stmts of         Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do           debugM $ "LocatedL [ExprLStmt: snocView"@@ -4914,7 +4837,7 @@ -- | Print a comment, using the current layout offset to convert the -- @DeltaPos@ to an absolute position. printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()-printQueuedComment loc Comment{commentContents} dp = do+printQueuedComment _loc Comment{commentContents} dp = do   p <- getPosP   d <- getPriorEndD   colOffset <- getLayoutOffsetP@@ -4922,7 +4845,6 @@   -- do not lose comments against the left margin   when (isGoodDelta (deltaPos dr (max 0 dc))) $ do     printCommentAt (undelta p dp colOffset) commentContents-    -- setPriorEndASTD False loc   p' <- getPosP   d' <- getPriorEndD   debugM $ "printQueuedComment: (p,p',d,d')=" ++ show (p,p',d,d')@@ -4951,7 +4873,7 @@   debugM $ "setLayoutTopLevelP entered"   oldAnchorOffset <- getLayoutOffsetP   modify (\a -> a { pMarkLayout = False-                  , pLHS = 0} )+                  , pLHS = 1} )   r <- k   debugM $ "setLayoutTopLevelP:resetting"   setLayoutOffsetP oldAnchorOffset@@ -5081,11 +5003,11 @@       printWhitespace (undelta p dp colOffset)       -- Sync point. We only call advance as we start the sub-span       -- processing, so force the dPriorEndPosition to ???-      p <- getPosP+      p0 <- getPosP       d <- getPriorEndD       r <- getAnchorU       setPriorEndD (fst $ rs2range r)-      debugM $ "advance:after: (posp, posd, posd')=" ++ show (p,d,fst $ rs2range r)+      debugM $ "advance:after: (posp, posd, posd')=" ++ show (p0,d,fst $ rs2range r)     else       return () 

@@ -87,6 +87,7 @@         , decl2Sig, decl2Bind         ) where +import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils @@ -311,13 +312,8 @@         in           (dp0, EpaCommentsBalanced (c':t) ts)       _ -> (dp, cs)-    -- go (L (Anchor rr (MovedAnchor ma)) c) = (dp, L (Anchor rr (MovedAnchor ma)) c)     go (L (Anchor rr (MovedAnchor ma)) c) = (d,  L (Anchor rr (MovedAnchor ma)) c)     go (L (Anchor rr                _) c) = (d,  L (Anchor rr (MovedAnchor dp)) c)--- setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor _)) an cs) l) a) dp---   = L (SrcSpanAnn---            (EpAnn (Anchor r (MovedAnchor dp)) an cs)---            l) a setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp   = case sortEpaComments (priorComments cs) of       [] ->@@ -331,7 +327,7 @@               where                 cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')                 lc = head $ reverse $ (L ca c:cs')-                delta = ss2delta (ss2pos $ anchor $ getLoc lc) r+                delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r                 line = getDeltaLine delta                 col = deltaColumn delta                 edp' = if line == 0 then SameLine col@@ -383,7 +379,6 @@     -- TODO: what happens if the receiving side already has comments?     (L anc _:_) -> do       logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc-      -- return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b)       return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b) transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do   logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn"@@ -440,9 +435,6 @@   => LHsDecl GhcPs -> LHsDecl GhcPs   -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs) balanceComments first second = do-  -- ++AZ++ : replace the nested casts with appropriate gmapM-  -- logTr $ "balanceComments entered"-  -- logDataWithAnnsTr "first" first   case first of     (L l (ValD x fb@(FunBind{}))) -> do       (L l' fb',second') <- balanceCommentsFB (L l fb) second@@ -485,7 +477,6 @@         [] -> moveLeadingComments m'' lf'         _  -> (m'',lf')   logTr $ "balanceCommentsMatch done"-  -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second')   balanceComments' (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t)) second' balanceCommentsFB f s = balanceComments' f s @@ -494,13 +485,7 @@ balanceCommentsMatch :: (Monad m)   => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do-  logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))-  -- logTr $ "balanceCommentsMatch: (move',stay')=" ++ showAst (move',stay')   logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo)-  -- logTr $ "balanceCommentsMatch: (loc1)=" ++ showGhc (ss2range (locA l))-  logTr $ "balanceCommentsMatch: (anc1,cs1f)=" ++ showAst (anc1,cs1f)-  logTr $ "balanceCommentsMatch: (move,stay)=" ++ showAst (move,stay)-  logTr $ "balanceCommentsMatch: (l'', grhss')=" ++ showAst (l'', grhss')   return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds')))   where     simpleBreak (r,_) = r /= 0@@ -711,11 +696,15 @@ commentOrigDelta :: LEpaComment -> LEpaComment commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp))   = (L (GHC.Anchor la op) (GHC.EpaComment t pp))+                  `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op))   where         (r,c) = ss2posEnd pp+         op' = if r == 0                then MovedAnchor (ss2delta (r,c+1) la)-               else MovedAnchor (ss2delta (r,c)   la)+               -- then MovedAnchor (ss2delta (r,c+0) la)+               -- else MovedAnchor (ss2delta (r,c)   la)+               else MovedAnchor (tweakDelta $ ss2delta (r,c)   la)         op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0)                then MovedAnchor (DifferentLine 1 0)                else op'@@ -733,7 +722,7 @@ -- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is -- fixed we have to special-case a funbind.  Damn. tweakListComments :: LHsDecl GhcPs -> LHsDecl GhcPs-tweakListComments a@(L l (ValD x fb@(FunBind{}))) = tweakListCommentsFB a+tweakListComments a@(L _ (ValD _ (FunBind{}))) = tweakListCommentsFB a tweakListComments a = tweakListComments' a  -- A LocatedA item may have both trailing comments and trailing list items.@@ -762,32 +751,37 @@             -> [TrailingAnn]             -> [LEpaComment]             -> (AnnListItem, b)-    process f (ll,cc) [] cs = (AnnListItem (reverse ll), f (cc++cs))+    process f (ll,cc) [] cs0 = (AnnListItem (reverse ll), f (cc++cs0))     process f (ll,cc) li [] = (AnnListItem (reverse $ ll++li), f cc)-    process f (ll,cc) (l:li) cs@(L lc c:_) = r+    process f (ll,cc) (l0:li) cs0 = r       where-        r = case trailingAnnLoc l of-          EpaSpan s -> r+        r = case trailingAnnLoc l0 of+          EpaSpan s -> r0             where               condp (L lc _) = anchor lc >= anchor anc-              (before,rest) = break condp cs+              (before,rest) = break condp cs0               cond (L lc _) = anchor lc >= s               (these,those) = break cond rest-              r = case these of-                [] -> process f (l:ll,cc) li cs+              r0 = case these of+                [] -> process f (l0:ll,cc) li cs0                 priors ->                       -- We have at least one comment preceding the list item                       let                         -- dp is the delta from the end of the last comment to                         -- the start of the AddXXXAnn delta-                        dp = spanOrigDelta (anchor $ getLoc $ last priors) s+                        dp = tweakDelta $ spanOrigDelta (anchor $ getLoc $ last priors) s                          l' = EpaDelta dp (commentOrigDeltas these)-                        cs' = those+                        cs1 = those                       in-                        process f (setTrailingAnnLoc l l':ll,before++cc) li cs'-          EpaDelta d' cs' -> process f (l:ll,cc) li cs+                        process f (setTrailingAnnLoc l0 l':ll,before++cc) li cs1+          EpaDelta _d' _cs' -> process f (l0:ll,cc) li cs0 +-- | For comment-related deltas starting on a new line we have an+-- off-by-one problem. Adjust+tweakDelta :: DeltaPos  -> DeltaPos+tweakDelta (SameLine d) = SameLine d+tweakDelta (DifferentLine l d) = DifferentLine l (d-1)  -- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is -- fixed we have to special-case a funbind.  Damn.@@ -800,24 +794,24 @@     -- first match for processing     (l',matches') = case matches of       [] -> (l,matches)-      (L lm m:ms) -> (l', L lm' m:ms)-                          `debug` ("tweakListCommentsFB:(l',lm')=" ++ showAst (l',lm'))+      (L lm0 m:ms) -> (l1, L lm' m:ms)+                          `debug` ("tweakListCommentsFB:(l',lm')=" ++ showAst (l1,lm'))       -- (L lm m:ms) -> error $ "lm'=\n" ++ showAst lm'         where-          (l',cs',as) = case l of+          (l1,cs',as) = case l of             SrcSpanAnn EpAnnNotUsed _ -> (l,[], [])-            SrcSpanAnn (EpAnn anc an (EpaComments cs))            l-              -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaComments [])) l, cs, lann_trailing an)-            SrcSpanAnn (EpAnn anc an (EpaCommentsBalanced ls ts)) l-              -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaCommentsBalanced ls [])) l, ts, lann_trailing an)+            SrcSpanAnn (EpAnn anc an (EpaComments cs))            l0+              -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaComments [])) l0, cs, lann_trailing an)+            SrcSpanAnn (EpAnn anc an (EpaCommentsBalanced ls ts)) l0+              -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaCommentsBalanced ls [])) l0, ts, lann_trailing an) -          lm' = case lm of-            SrcSpanAnn EpAnnNotUsed                               l-              -> SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem as) (EpaComments cs')) l-            SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaComments cs))            l-              -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaComments (cs'<>cs))) l-            SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaCommentsBalanced ls ts)) l-              -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaCommentsBalanced (cs'<>ls) ts)) l+          lm' = case lm0 of+            SrcSpanAnn EpAnnNotUsed                               l0+              -> SrcSpanAnn (EpAnn (spanAsAnchor l0) (AnnListItem as) (EpaComments cs')) l0+            SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaComments cs))            l0+              -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaComments (cs'<>cs))) l0+            SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaCommentsBalanced ls ts)) l0+              -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaCommentsBalanced (cs'<>ls) ts)) l0      r = (L l' (ValD xv (FunBind x n (MG mx (L lm (map tweakListComments' matches')) o) t))) tweakListCommentsFB x = error $ "tweakListCommentsFB for " ++ showAst x@@ -1262,8 +1256,8 @@ newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) newWhereAnnotation ww = do   newSpan <- uniqueSrcSpanT-  let anc  = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3))-  let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))+  let anc  = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))+  let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))   let w = case ww of         WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])]         WithoutWhere -> []

@@ -22,9 +22,6 @@ import Data.Maybe import Data.Ord (comparing) -import Data.Generics--import GHC.Hs.Dump import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Orphans () @@ -34,7 +31,7 @@ import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Data.FastString-import GHC.Utils.Outputable (showSDocUnsafe, showPprUnsafe)+import GHC.Utils.Outputable ( showPprUnsafe )  import Data.List (sortBy, elemIndex) @@ -81,8 +78,7 @@ -- | A good delta has no negative values. isGoodDelta :: DeltaPos -> Bool isGoodDelta (SameLine co) = co >= 0--- isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0-isGoodDelta (DifferentLine ro co) = ro > 0+isGoodDelta (DifferentLine ro _co) = ro > 0   -- Note: DifferentLine invariant is ro is nonzero and positive  @@ -237,8 +233,8 @@ comment2LEpaComment :: Comment -> LEpaComment comment2LEpaComment (Comment s anc r _mk) = mkLEpaComment s anc r - mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment+mkLEpaComment "" anc r = (L anc (GHC.EpaComment (EpaEofComment) r)) mkLEpaComment s anc r = (L anc (GHC.EpaComment (EpaLineComment s) r))  mkComment :: String -> Anchor -> RealSrcSpan -> Comment@@ -318,20 +314,23 @@  -- --------------------------------------------------------------------- -showAst :: (Data a) => a -> String-showAst ast-  = showSDocUnsafe-    $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast+-- Note: moved to Language.Haskell.GHC.ExactPrint.ExactPrint as a hack+-- to avoid import loop problems while we have to use the local+-- version of Dump+-- showAst :: (Data a) => a -> String+-- showAst ast+--   = showSDocUnsafe+--     $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast  -- ---------------------------------------------------------------------  setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l)    a) anc cs   = (L (SrcSpanAnn (EpAnn anc def cs) l) a)-     `debug` ("setAnchorAn: anc=" ++ showAst anc)+     -- `debug` ("setAnchorAn: anc=" ++ showAst anc) setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs   = (L (SrcSpanAnn (EpAnn anc an cs) l) a)-     `debug` ("setAnchorAn: anc=" ++ showAst anc)+     -- `debug` ("setAnchorAn: anc=" ++ showAst anc)  setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an setAnchorEpa EpAnnNotUsed   anc cs = EpAnn anc def cs@@ -344,7 +343,6 @@ setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule setAnchorHsModule hsmod anc cs = hsmod { hsmodAnn = an' }   where-    -- anc' = anc { anchor_op = MovedAnchor (SameLine 0)}     anc' = anc { anchor_op = UnchangedAnchor }     an' = setAnchorEpa (hsmodAnn hsmod) anc' cs 

@@ -191,12 +191,23 @@   let libdir = GHC.Paths.libdir   runTestText (putTextToHandle stdout True) $ TestList [ -    mkTestModChange libdir rmDecl7 "RmDecl7.hs"+    -- mkTestModChange libdir rmDecl7 "RmDecl7.hs" +    -- mkTestModChange libdir changeLocalDecls  "LocalDecls.hs"     -- mkTestModChange libdir changeLayoutLet2 "LayoutLet2.hs"-    -- mkParserTestMD libdir      "transform" "LayoutLet2.hs"-    -- mkParserTest libdir      "ghc80" "T10970a.hs"+    -- mkTestModChange libdir addLocaLDecl5  "AddLocalDecl5.hs"++   -- mkTestModChange libdir rmDecl1 "RmDecl1.hs"++   -- mkTestModChange libdir rmDecl4 "RmDecl4.hs"+    -- mkParserTestMD libdir      "ghc92" "Foo.hs"+    -- mkParserTest libdir      "ghc92" "Foo.hs"+    mkParserTestMD libdir      "ghc92" "Foo.hs"+    -- mkParserTest libdir      "ghc92" "Foo2.hs"+    -- mkParserTest libdir      "ghc710" "EmptyMostly.hs"     -- mkParserTestBC libdir "ghc710" "Control.hs"+    -- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs"+    -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"     -- Needs GHC changes 

@@ -31,6 +31,7 @@   import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess

@@ -15,6 +15,7 @@ -- import qualified Data.ByteString as B  import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils

@@ -7,6 +7,7 @@ module Test.Transform where  import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Utils@@ -186,8 +187,8 @@                         -> Transform (LMatch GhcPs (LHsExpr GhcPs))       replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do         newSpan <- uniqueSrcSpanT-        let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)))-        let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)))+        let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)))+        let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)))         let an = EpAnn anc                         (AnnList (Just anc2) Nothing Nothing                                  [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])@@ -261,7 +262,7 @@         -- let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van         -- let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs)         let (EpAnn anc (AnnList _ a b c dd) cs) = van-        let van' = (EpAnn anc (AnnList (Just (Anchor (anchor anc) (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs)+        let van' = (EpAnn anc (AnnList (Just (Anchor (anchor anc) (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs)         let binds' = (HsValBinds van'                           (ValBinds sortKey                                     (listToBag $ decl':oldBinds)@@ -473,7 +474,7 @@ addLocaLDecl1 :: Changer addLocaLDecl1 libdir lp = do   Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2")-  let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 5)+  let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 4)       doAddLocal = do         (de1:d2:d3:_) <- hsDecls (makeDeltaAst lp)         (de1'',d2') <- balanceComments de1 d2

@@ -0,0 +1,11 @@++asyncUsing :: (IO () -> IO ThreadId)+           -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+   var <- newEmptyTMVarIO+   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+   -- slightly faster:+   t <- mask $ \restore ->+          doFork $ try (restore action) >>= atomically . putTMVar var+   return (Async t (readTMVar var))+

@@ -0,0 +1,7 @@+module Operator2 where++main = do+  return ({- comment -} x >= 1 || y >= 2)++  putStrLn $ show $ {- comment here -} foo || bar+  print $ {- comment here -} foo || bar

@@ -0,0 +1,4 @@+yes p1001 p1002+  | g1001 = e1001+  | g1002 = e1002+  | otherwise = e1003