ghc-exactprint 1.6.1.3 → 1.7.0.0

raw patch · 30 files changed

+643/−977 lines, 30 filesdep +extradep ~basedep ~filemanipdep ~ghc-pathsPVP ok

version bump matches the API change (PVP)

Dependencies added: extra

Dependency ranges changed: base, filemanip, ghc-paths

API changes (from Hackage documentation)

Files

• ChangeLog +3/−6
• ghc-exactprint.cabal +9/−12
• src/Language/Haskell/GHC/ExactPrint/Dump.hs +1/−2
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +229/−288
• src/Language/Haskell/GHC/ExactPrint/Lookup.hs +0/−1
• src/Language/Haskell/GHC/ExactPrint/Orphans.hs +16/−0
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +7/−12
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +17/−28
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +55/−71
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +27/−67
• tests/Test.hs +18/−23
• tests/Test/Common.hs +1/−1
• tests/Test/CommonUtils.hs +30/−20
• tests/Test/NoAnnotations.hs +3/−6
• tests/Test/Transform.hs +8/−9
• tests/examples/ghc94/Haddock.hs +0/−408
• tests/examples/ghc94/Haddock1.hs +0/−23
• tests/examples/ghc96/ContinuationIO.hs +3/−0
• tests/examples/ghc96/Lib.hs +13/−0
• tests/examples/ghc96/Main.hs +21/−0
• tests/examples/ghc96/T11671_run.hs +48/−0
• tests/examples/ghc96/T22315b.hs +10/−0
• tests/examples/ghc96/T22332a.hs +28/−0
• tests/examples/ghc96/T22500.hs +10/−0
• tests/examples/ghc96/TDDataConstructor.hs +6/−0
• tests/examples/ghc96/TDExistential.hs +14/−0
• tests/examples/ghc96/TDGADT.hs +14/−0
• tests/examples/ghc96/TDGoodConsConstraints.hs +11/−0
• tests/examples/ghc96/TDVector.hs +22/−0
• tests/examples/ghc96/TD_TH_splice.hs +19/−0

@@ -1,9 +1,6 @@-2023-06-04 v1.6.1.3-	* Fix support for exact printing when using GHC option --haddock #125-2023-05-31 v1.6.1.2-	* Add GHC 9.4.5 to CI-	* Add support for exact printing when using GHC option --haddock #125-2022-11-08 v1.6.1.1+2022-11-08 v1.7+	* Support GHC 9.6.1+2022-11-08 v1.6.1 	* Add GHC 9.4.4 to CI 	* Add support for exact printing HsDocTy. #121 2022-11-08 v1.6.1

@@ -1,11 +1,11 @@ name:                ghc-exactprint-version:             1.6.1.3+version:             1.7.0.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                      be compiled by GHC, currently excluding lhs files.                      .-                     Note: requires GHC 9.4.*. For earlier GHC+                     Note: requires GHC 9.6.*. For earlier GHC                      versions see lower version numbers.                      . @@ -15,11 +15,7 @@ maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:         GHC == 9.4.1-                   , GHC == 9.4.2-                   , GHC == 9.4.3-                   , GHC == 9.4.4-                   , GHC == 9.4.5+tested-with:         GHC == 9.6.1 extra-source-files:  ChangeLog                      tests/examples/failing/*.hs                      tests/examples/ghc710-only/*.hs@@ -33,6 +29,7 @@                      tests/examples/ghc90/*.hs                      tests/examples/ghc92/*.hs                      tests/examples/ghc94/*.hs+                     tests/examples/ghc96/*.hs                      tests/examples/pre-ghc810/*.hs                      tests/examples/pre-ghc86/*.hs                      tests/examples/pre-ghc90/*.hs@@ -76,7 +73,7 @@   -- other-extensions:   GHC-Options:         -Wall -Wredundant-constraints   -- GHC-Options:         -Weverything-  build-depends:       base >=4.17 && <4.18+  build-depends:       base >=4.18 && <4.19                      , bytestring >= 0.10.6                      , containers >= 0.5                      , ordered-containers@@ -92,7 +89,7 @@     default-language:    Haskell2010-  if impl (ghc < 9.4)+  if impl (ghc < 9.6)       buildable: False  Test-Suite test@@ -111,20 +108,20 @@   GHC-Options:         -threaded -Wall -Wredundant-constraints   Default-language:    Haskell2010   Build-depends:       HUnit >= 1.2-                     , base < 4.18+                     , base < 4.19                      , bytestring                      , containers >= 0.5                      , ordered-containers                      , data-default                      , Diff                      , directory >= 1.2+                     , extra                      , filepath  >= 1.4                      , ghc       >= 9.4.1                      , ghc-paths  >= 0.1                      , mtl        >= 2.2.1                      , syb        >= 0.5                      , silently   >= 1.2-                     , filemanip  >= 0.3                      -- for the lib only                      , fail >= 4.9 && <4.10                      , ghc-boot@@ -153,7 +150,7 @@                , filepath                , ghc                , ghc-exactprint-               -- , ghc-paths+               , ghc-paths                , syb                , temporary                , time

@@ -28,7 +28,6 @@ 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)@@ -139,7 +138,7 @@               _                -> parens $ text "SourceText" <+> text "blanked"              epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r+            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"

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP   #-} {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}@@ -14,7 +13,9 @@ {-# LANGUAGE TypeOperators        #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns         #-}+{-# LANGUAGE BlockArguments       #-} {-# LANGUAGE UndecidableInstances  #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Language.Haskell.GHC.ExactPrint.ExactPrint   (@@ -34,8 +35,6 @@   ) where  import GHC--- import GHC.Types.SrcLoc (mkRealSrcLoc, mkRealSrcSpan)-import GHC.Base (NonEmpty(..) ) import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF@@ -44,40 +43,37 @@ import GHC.Types.Basic hiding (EP) import GHC.Types.Fixity import GHC.Types.ForeignCall-#if MIN_VERSION_ghc(9,4,3) import GHC.Types.Name.Reader-#endif-import GHC.Types.SourceText import GHC.Types.PkgQual+import GHC.Types.SourceText import GHC.Types.Var import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict --- import GHC.Types.PkgQual+import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Control.Monad.Identity+import Control.Monad (forM, when, unless)+import Control.Monad.Identity (Identity(..)) import qualified Control.Monad.Reader as Reader-import Control.Monad.RWS+import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask)+import Control.Monad.Trans (lift) import Data.Data ( Data ) import Data.Dynamic import Data.Foldable import Data.Functor.Const-import Data.List--- import qualified Data.Set.Ordered as OSet import qualified Data.Set as Set import Data.Typeable--- import Data.List ( partition, sortBy)+import Data.List ( partition, sort, sortBy) import Data.Maybe ( isJust, mapMaybe )- 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--- import GHC.Plugins (mkRealSrcLoc)  -- import Debug.Trace @@ -90,6 +86,7 @@ showAst ast   = showSDocUnsafe     $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast+ -- ---------------------------------------------------------------------  exactPrint :: ExactPrint ast => ast -> String@@ -387,7 +384,7 @@   when (flush == NoFlushComments) $ do     when ((getFollowingComments cs) /= []) $ do       debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)-      mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)+      mapM_ printOneComment (map tokComment $ getFollowingComments cs)       debugM $ "ending trailing comments"    let newAchor = anchor' { anchor_op = MovedAnchor edp }@@ -403,7 +400,7 @@ -- ---------------------------------------------------------------------  addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()-addCommentsA csNew = addComments (concatMap tokComment csNew)+addCommentsA csNew = addComments (map tokComment csNew)  {- TODO: When we addComments, some may have an anchor that is no longer@@ -440,7 +437,7 @@   mapM_ printOneComment (sortComments cs)   debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)   debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)-  mapM_ printOneComment (concatMap tokComment (filterEofComment True trailing))+  mapM_ printOneComment (map tokComment (filterEofComment True trailing))   debugM $ "flushing comments done"  filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]@@ -512,17 +509,22 @@ printStringAtRsC :: (Monad m, Monoid w)   => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation printStringAtRsC capture pa str = do+  debugM $ "printStringAtRsC: pa=" ++ showAst pa   printComments pa   pe <- getPriorEndD-  debugM $ "printStringAtRs:pe=" ++ show pe+  debugM $ "printStringAtRsC:pe=" ++ show pe   let p = ss2delta pe pa   p' <- adjustDeltaForOffsetM p+  debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p')   printStringAtLsDelta p' str   setPriorEndASTD True pa   cs' <- case capture of     CaptureComments -> takeAppliedComments     NoCaptureComments -> return []-  debugM $ "printStringAtRs:cs'=" ++ show cs'+  debugM $ "printStringAtRsC:cs'=" ++ show cs'+  debugM $ "printStringAtRsC:p'=" ++ showAst p'+  debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' [])+  debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs'))   return (EpaDelta p' (map comment2LEpaComment cs'))  printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m ()@@ -561,9 +563,9 @@  printStringAtAAC :: (Monad m, Monoid w)   => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation-printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s+printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s printStringAtAAC capture (EpaDelta d cs) s = do-  mapM_  printOneComment $ concatMap tokComment cs+  mapM_ (printOneComment . tokComment) cs   pe1 <- getPriorEndD   p1 <- getPosP   printStringAtLsDelta d s@@ -724,12 +726,10 @@ type ASetter a b =                         (b -> Identity b) -> (a -> Identity a)  view :: MonadReader s m => Getting s a -> m a--- view l = Reader.asks (getConst #. l Const) view l = Reader.asks (getConst . l Const) {-# INLINE view #-}  over :: ASetter a b -> (b -> b) -> (a -> a)--- over l f = runIdentity #. l (Identity #. f) over l f = runIdentity . l (Identity . f) {-# INLINE over #-} @@ -1121,13 +1121,6 @@   t <- markTrailing (lann_trailing a)   return (EpAnn anc (a { lann_trailing = t }) cs) --- 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-- markEpAnnL :: (Monad m, Monoid w)   => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed@@ -1154,14 +1147,6 @@     [a'] -> return a'     _ -> error "Should not happen: markAddEpAnn" -mark :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m Int-mark anns kw = do-  case find (\(AddEpAnn k _) -> k == kw) anns of-    Just aa -> markKw aa >> return 1-    Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of-      Just aau -> markKw aau >> return 1-      Nothing -> return 1- mark' :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn] mark' anns kw = do   case find' kw anns of@@ -1309,7 +1294,6 @@     (r,c) = ss2posEnd pp     la = anchor anc     dp'' = if r == 0-           -- then (ss2delta (r,c+1) la)            then (ss2delta (r,c+0) la)            else (ss2delta (r,c)   la)     dp' = if pp == anchor anc@@ -1396,16 +1380,16 @@ -- ---------------------------------------------------------------------  -- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource'-instance ExactPrint HsModule where-  getAnnotationEntry hsmod = fromAnn' (hsmodAnn hsmod)+instance ExactPrint (HsModule GhcPs) where+  getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt hsmod)+  -- A bit pointless actually changing anything here   setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs                    `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) -  exact hsmod@(HsModule EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod >> return hsmod-  exact (HsModule an lo mmn mexports imports decls mdeprec mbDoc) = do+  exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod+  exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do -    let mbDoc' = mbDoc-    -- mbDoc' <- markAnnotated mbDoc+    mbDoc' <- markAnnotated mbDoc      (an0, mmn' , mdeprec', mexports') <-       case mmn of@@ -1415,9 +1399,7 @@           m' <- markAnnotated m            mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec-           mexports' <- setLayoutTopLevelP $ markAnnotated mexports-           an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere            return (an1, Just m', mdeprec', mexports')@@ -1434,7 +1416,7 @@     let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}     debugM $ "HsModule, anf=" ++ showAst anf -    return (HsModule anf lo mmn' mexports' imports' decls' mdeprec' mbDoc')+    return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls')  -- --------------------------------------------------------------------- @@ -1471,11 +1453,13 @@ -- ---------------------------------------------------------------------  instance ExactPrint (ImportDecl GhcPs) where-  getAnnotationEntry idecl = fromAnn (ideclExt idecl)-  setAnnotationAnchor idecl anc cs = idecl { ideclExt = setAnchorEpa (ideclExt idecl) anc cs }+  getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl)+  setAnnotationAnchor idecl anc cs = idecl { ideclExt+                    = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} } -  exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x-  exact (ImportDecl ann msrc m mpkg src safeflag qualFlag impl mAs hiding) = do+  exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x+  exact (ImportDecl (XImportDeclPass ann msrc impl)+                     modname mpkg src safeflag qualFlag mAs hiding) = do      ann0 <- markLensKw ann limportDeclAnnImport AnnImport     let (EpAnn _anc an _cs) = ann0@@ -1508,7 +1492,7 @@        RawPkgQual (StringLiteral src' v _) ->          printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v))        _ -> return ann2-    m' <- markAnnotated m+    modname' <- markAnnotated modname      ann4 <-       case qualFlag of@@ -1536,7 +1520,8 @@                   , importDeclAnnPragma = importDeclAnnPragma'                   } -    return (ImportDecl (EpAnn anc' an2 cs') msrc m' mpkg src safeflag qualFlag impl mAs' hiding')+    return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl)+                     modname' mpkg src safeflag qualFlag mAs' hiding')   -- ---------------------------------------------------------------------@@ -1544,26 +1529,9 @@ instance ExactPrint HsDocString where   getAnnotationEntry _ = NoEntryVal   setAnnotationAnchor a _ _ = a-  exact (MultiLineDocString decorator (x :| xs)) = do-    printStringAdvance ("-- " ++ printDecorator decorator)-    pe <- getPriorEndD-    debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x)-    x' <- markAnnotated x-    xs' <- markAnnotated (map dedentDocChunk xs)-    return (MultiLineDocString decorator (x' :| xs'))-  exact x = do-    -- TODO: can this happen?-    debugM $ "Not exact printing:" ++ showAst x-    return x---instance ExactPrint HsDocStringChunk where-  getAnnotationEntry _ = NoEntryVal-  setAnnotationAnchor a _ _ = a-  exact chunk = do-    printStringAdvance ("--" ++ unpackHDSC chunk)-    return chunk-+  exact ds = do+    (printStringAdvance . exactPrintHsDocString) ds+    return ds  instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where   getAnnotationEntry _ = NoEntryVal@@ -1622,9 +1590,9 @@   exact (ClsInstD     a  cid) = do     cid' <- markAnnotated cid     return (ClsInstD     a  cid')-  exact (DataFamInstD x decl) = do+  exact (DataFamInstD a decl) = do     d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl)-    return (DataFamInstD x (dc_d d'))+    return (DataFamInstD a (dc_d d'))   exact (TyFamInstD a eqn) = do     eqn' <- markAnnotated eqn     return (TyFamInstD a eqn')@@ -1633,7 +1601,7 @@  data DataFamInstDeclWithContext   = DataFamInstDeclWithContext-    { _dc_a :: EpAnn [AddEpAnn] -- TODO: remove this field+    { _dc_a :: EpAnn [AddEpAnn]     , _dc_f :: TopLevelFlag     , dc_d :: DataFamInstDecl GhcPs     }@@ -1741,25 +1709,25 @@  -- --------------------------------------------------------------------- -instance ExactPrint ForeignImport where+instance ExactPrint (ForeignImport GhcPs) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a-  exact (CImport cconv safety@(L ll _) mh imp (L ls src)) = do+  exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do     cconv' <- markAnnotated cconv     unless (ll == noSrcSpan) $ markAnnotated safety >> return ()     unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return ()-    return (CImport cconv' safety mh imp (L ls src))+    return (CImport (L ls src) cconv' safety mh imp)  -- --------------------------------------------------------------------- -instance ExactPrint ForeignExport where+instance ExactPrint (ForeignExport GhcPs) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a-  exact (CExport spec (L ls src)) = do+  exact (CExport (L ls src) spec) = do     debugM $ "CExport starting"     spec' <- markAnnotated spec     unless (ls == noSrcSpan) $ markExternalSourceText ls src ""-    return (CExport spec' (L ls src))+    return (CExport (L ls src) spec')  -- --------------------------------------------------------------------- @@ -1788,14 +1756,14 @@ -- ---------------------------------------------------------------------  instance ExactPrint (WarnDecls GhcPs) where-  getAnnotationEntry (Warnings an _ _) = fromAnn an-  setAnnotationAnchor (Warnings an a b) anc cs = Warnings (setAnchorEpa an anc cs) a b+  getAnnotationEntry (Warnings (an,_) _) = fromAnn an+  setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b -  exact (Warnings an src warns) = do+  exact (Warnings (an,src) warns) = do     an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED     warns' <- markAnnotated warns     an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")-    return (Warnings an1 src warns')+    return (Warnings (an1,src) warns')  -- --------------------------------------------------------------------- @@ -1838,29 +1806,29 @@   -- exact fs = printStringAdvance (show (unpackFS fs))   exact fs = printStringAdvance (unpackFS fs) >> return fs - -- ---------------------------------------------------------------------  instance ExactPrint (RuleDecls GhcPs) where-  getAnnotationEntry (HsRules an _ _) = fromAnn an-  setAnnotationAnchor (HsRules an a b) anc cs = HsRules (setAnchorEpa an anc cs) a b-  exact (HsRules an src rules) = do+  getAnnotationEntry (HsRules (an,_) _) = fromAnn an+  setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b+  exact (HsRules (an, src) rules) = do     an0 <-       case src of         NoSourceText      -> markEpAnnLMS an lidl AnnOpen  (Just "{-# RULES")         SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen  (Just srcTxt)     rules' <- markAnnotated rules     an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")-    return (HsRules an1 src rules')+    return (HsRules (an1,src) rules')  -- ---------------------------------------------------------------------  instance ExactPrint (RuleDecl GhcPs) where-  getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an-  setAnnotationAnchor r anc cs = r { rd_ext = setAnchorEpa (rd_ext r) anc cs}-  exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do+  getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an+  setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs+    = r { rd_ext = (setAnchorEpa an anc cs, a)}+  exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do     debugM "HsRule entered"-    ln' <- markAnnotated ln+    (L ln' _) <- markAnnotated (L ln (nsrc, n))     debugM "HsRule after ln"     an0 <- markActivation an lra_rest act     debugM "HsRule after act"@@ -1880,7 +1848,7 @@     lhs' <- markAnnotated lhs     an4 <- markEpAnnL an3 lra_rest AnnEqual     rhs' <- markAnnotated rhs-    return (HsRule an4 ln' act mtybndrs' termbndrs' lhs' rhs')+    return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs')  markActivation :: (Monad m, Monoid w)   => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a)@@ -1920,12 +1888,11 @@   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a -  exact v = return v-  -- exact v = case v of-  --   (DocCommentNext ds)    -> DocCommentNext <$> exact ds-  --   (DocCommentPrev ds)    -> DocCommentPrev <$> exact ds-  --   (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds-  --   (DocGroup i ds)        -> DocGroup i <$> exact ds+  exact v = case v of+    (DocCommentNext ds)    -> DocCommentNext <$> exact ds+    (DocCommentPrev ds)    -> DocCommentPrev <$> exact ds+    (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds+    (DocGroup i ds)        -> DocGroup i <$> exact ds  -- --------------------------------------------------------------------- @@ -2145,7 +2112,7 @@   setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs}   setAnnotationAnchor a _ _ = a -  exact (FunBind x fid matches t) = do+  exact (FunBind x fid matches) = do     matches' <- markAnnotated matches     let       fun_id' = case unLoc (mg_alts matches') of@@ -2153,11 +2120,12 @@         (L _ m:_) -> case m_ctxt m of           FunRhs f _ _ -> f           _ -> fid-    return (FunBind x fun_id' matches' t)-  exact (PatBind x pat grhss t) = do+    return (FunBind x fun_id' matches')++  exact (PatBind x pat grhss) = do     pat' <- markAnnotated pat     grhss' <- markAnnotated grhss-    return (PatBind x pat' grhss' t)+    return (PatBind x pat' grhss')   exact (PatSynBind x bind) = do     bind' <- markAnnotated bind     return (PatSynBind x bind')@@ -2328,36 +2296,15 @@  -- --------------------------------------------------------------------- --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/20247--- is fixed-fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList-fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed-fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)-  = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)----- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256-fixAnnListAnn :: EpAnn AnnList -> EpAnn AnnList-fixAnnListAnn EpAnnNotUsed = EpAnnNotUsed-fixAnnListAnn (EpAnn anchor (AnnList ma o c r t) cs)-  = (EpAnn (widenAnchor anchor r) (AnnList ma o c r t) cs)---- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256-fixSrcAnnL :: SrcSpanAnnL -> SrcSpanAnnL-fixSrcAnnL (SrcSpanAnn an l) = SrcSpanAnn (fixAnnListAnn an) l---- ---------------------------------------------------------------------- instance ExactPrint (HsLocalBinds GhcPs) where-  getAnnotationEntry (HsValBinds an _) = fromAnn (fixValbindsAnn an)+  getAnnotationEntry (HsValBinds an _) = fromAnn an   getAnnotationEntry (HsIPBinds{}) = NoEntryVal   getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal    setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a   setAnnotationAnchor a _ _ = a -  exact (HsValBinds an' valbinds) = do-    let an = fixValbindsAnn an'+  exact (HsValBinds an valbinds) = do     debugM $ "exact HsValBinds: an=" ++ showAst an     an0 <- markEpAnnL an lal_rest AnnWhere @@ -2474,26 +2421,24 @@   getAnnotationEntry (TypeSig a _ _)  = fromAnn a   getAnnotationEntry (PatSynSig a _ _) = fromAnn a   getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a-  getAnnotationEntry (IdSig {}) = NoEntryVal   getAnnotationEntry (FixSig a _) = fromAnn a   getAnnotationEntry (InlineSig a _ _) = fromAnn a   getAnnotationEntry (SpecSig a _ _ _) = fromAnn a-  getAnnotationEntry (SpecInstSig a _ _) = fromAnn a-  getAnnotationEntry (MinimalSig a _ _) = fromAnn a-  getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a-  getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a+  getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a+  getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a+  getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a+  getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a    setAnnotationAnchor (TypeSig a x y)  anc           cs = (TypeSig (setAnchorEpa a anc cs) x y)   setAnnotationAnchor (PatSynSig a x y) anc          cs = (PatSynSig (setAnchorEpa a anc cs) x y)   setAnnotationAnchor (ClassOpSig a x y z) anc       cs = (ClassOpSig (setAnchorEpa a anc cs) x y z)-  setAnnotationAnchor i@(IdSig {}) _ _s = i   setAnnotationAnchor (FixSig a x) anc               cs = (FixSig (setAnchorEpa a anc cs) x)   setAnnotationAnchor (InlineSig a x y) anc          cs = (InlineSig (setAnchorEpa a anc cs) x y)   setAnnotationAnchor (SpecSig a x y z) anc          cs = (SpecSig (setAnchorEpa a anc cs) x y z)-  setAnnotationAnchor (SpecInstSig a x y) anc        cs = (SpecInstSig (setAnchorEpa a anc cs) x y)-  setAnnotationAnchor (MinimalSig a x y) anc         cs = (MinimalSig (setAnchorEpa a anc cs) x y)-  setAnnotationAnchor (SCCFunSig a x y z) anc        cs = (SCCFunSig (setAnchorEpa a anc cs) x y z)-  setAnnotationAnchor (CompleteMatchSig a x y z) anc cs = (CompleteMatchSig (setAnchorEpa a anc cs) x y z)+  setAnnotationAnchor (SpecInstSig (a,x) y) anc      cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y)+  setAnnotationAnchor (MinimalSig (a,x) y) anc       cs = (MinimalSig ((setAnchorEpa a anc cs),x) y)+  setAnnotationAnchor (SCCFunSig (a,x) y z) anc      cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z)+  setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z)    exact (TypeSig an vars ty)  = do     (an', vars', ty') <- exactVarSig an vars ty@@ -2545,27 +2490,27 @@     an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}")     return (SpecSig an3 ln' typs' inl) -  exact (SpecInstSig an src typ) = do+  exact (SpecInstSig (an,src) typ) = do     an0 <- markAnnOpen an src "{-# SPECIALISE"     an1 <- markEpAnnL an0 lidl AnnInstance     typ' <- markAnnotated typ     an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}")-    return (SpecInstSig an2 src typ')+    return (SpecInstSig (an2,src) typ') -  exact (MinimalSig an src formula) = do+  exact (MinimalSig (an,src) formula) = do     an0 <- markAnnOpen an src "{-# MINIMAL"     formula' <- markAnnotated formula     an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")-    return (MinimalSig an1 src formula')+    return (MinimalSig (an1,src) formula') -  exact (SCCFunSig an src ln ml) = do+  exact (SCCFunSig (an,src) ln ml) = do     an0 <- markAnnOpen an src "{-# SCC"     ln' <- markAnnotated ln     ml' <- markAnnotated ml     an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")-    return (SCCFunSig an1 src ln' ml')+    return (SCCFunSig (an1,src) ln' ml') -  exact (CompleteMatchSig an src cs mty) = do+  exact (CompleteMatchSig (an,src) cs mty) = do     an0 <- markAnnOpen an src "{-# COMPLETE"     cs' <- markAnnotated cs     (an1, mty') <-@@ -2576,9 +2521,7 @@           ty' <- markAnnotated ty           return (an1, Just ty')     an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}")-    return (CompleteMatchSig an2 src cs' mty')--  exact x = error $ "exact Sig for:" ++ showAst x+    return (CompleteMatchSig (an2,src) cs' mty')  -- --------------------------------------------------------------------- @@ -2619,10 +2562,10 @@ -- ---------------------------------------------------------------------  instance ExactPrint (AnnDecl GhcPs) where-  getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an-  setAnnotationAnchor (HsAnnotation an a b c) anc cs = HsAnnotation (setAnchorEpa an anc cs) a b c+  getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an+  setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c -  exact (HsAnnotation an src prov e) = do+  exact (HsAnnotation (an, src) prov e) = do     an0 <- markAnnOpenP an src "{-# ANN"     (an1, prov') <-       case prov of@@ -2639,7 +2582,7 @@      e' <- markAnnotated e     an2 <- markAnnCloseP an1-    return (HsAnnotation an2 src prov' e')+    return (HsAnnotation (an2,src) prov' e')  -- --------------------------------------------------------------------- @@ -2704,14 +2647,14 @@   getAnnotationEntry (HsVar{})                    = NoEntryVal   getAnnotationEntry (HsUnboundVar an _)          = fromAnn an   getAnnotationEntry (HsRecSel{})                 = NoEntryVal-  getAnnotationEntry (HsOverLabel an _)           = fromAnn an+  getAnnotationEntry (HsOverLabel an _ _)         = fromAnn an   getAnnotationEntry (HsIPVar an _)               = fromAnn an   getAnnotationEntry (HsOverLit an _)             = fromAnn an   getAnnotationEntry (HsLit an _)                 = fromAnn an   getAnnotationEntry (HsLam _ _)                  = NoEntryVal   getAnnotationEntry (HsLamCase an _ _)           = fromAnn an   getAnnotationEntry (HsApp an _ _)               = fromAnn an-  getAnnotationEntry (HsAppType _ _ _)            = NoEntryVal+  getAnnotationEntry (HsAppType _ _ _ _)          = NoEntryVal   getAnnotationEntry (OpApp an _ _ _)             = fromAnn an   getAnnotationEntry (NegApp an _ _)              = fromAnn an   getAnnotationEntry (HsPar an _ _ _)             = fromAnn an@@ -2733,7 +2676,8 @@   getAnnotationEntry (ArithSeq an _ _)            = fromAnn an   getAnnotationEntry (HsTypedBracket an _)        = fromAnn an   getAnnotationEntry (HsUntypedBracket an _)      = fromAnn an-  getAnnotationEntry (HsSpliceE an _)             = fromAnn an+  getAnnotationEntry (HsTypedSplice (_, an) _)    = fromAnn an+  getAnnotationEntry (HsUntypedSplice an _)       = fromAnn an   getAnnotationEntry (HsProc an _ _)              = fromAnn an   getAnnotationEntry (HsStatic an _)              = fromAnn an   getAnnotationEntry (HsPragE{})                  = NoEntryVal@@ -2741,14 +2685,14 @@   setAnnotationAnchor a@(HsVar{})              _ _s = a   setAnnotationAnchor (HsUnboundVar an a)    anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a)   setAnnotationAnchor a@(HsRecSel{})           _ _s  = a-  setAnnotationAnchor (HsOverLabel an a)     anc cs = (HsOverLabel (setAnchorEpa an anc cs) a)+  setAnnotationAnchor (HsOverLabel an s a)   anc cs = (HsOverLabel (setAnchorEpa an anc cs) s a)   setAnnotationAnchor (HsIPVar an a)         anc cs = (HsIPVar (setAnchorEpa an anc cs) a)   setAnnotationAnchor (HsOverLit an a)       anc cs = (HsOverLit (setAnchorEpa an anc cs) a)   setAnnotationAnchor (HsLit an a)           anc cs = (HsLit (setAnchorEpa an anc cs) a)   setAnnotationAnchor a@(HsLam _ _)            _ _s = a   setAnnotationAnchor (HsLamCase an a b)     anc cs = (HsLamCase (setAnchorEpa an anc cs) a b)   setAnnotationAnchor (HsApp an a b)         anc cs = (HsApp (setAnchorEpa an anc cs) a b)-  setAnnotationAnchor a@(HsAppType _ _ _)      _ _s = a+  setAnnotationAnchor a@(HsAppType {})      _ _s = a   setAnnotationAnchor (OpApp an a b c)       anc cs = (OpApp (setAnchorEpa an anc cs) a b c)   setAnnotationAnchor (NegApp an a b)        anc cs = (NegApp (setAnchorEpa an anc cs) a b)   setAnnotationAnchor (HsPar an a b c)       anc cs = (HsPar (setAnchorEpa an anc cs) a b c)@@ -2770,9 +2714,10 @@   setAnnotationAnchor (ArithSeq an a b)      anc cs = (ArithSeq (setAnchorEpa an anc cs) a b)   setAnnotationAnchor (HsTypedBracket an a)   anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a)   setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a)-  setAnnotationAnchor (HsSpliceE an a)       anc cs = (HsSpliceE (setAnchorEpa an anc cs) a)-  setAnnotationAnchor (HsProc an a b)        anc cs = (HsProc (setAnchorEpa an anc cs) a b)-  setAnnotationAnchor (HsStatic an a)        anc cs = (HsStatic (setAnchorEpa an anc cs) a)+  setAnnotationAnchor (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e)+  setAnnotationAnchor (HsUntypedSplice an e)  anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e)+  setAnnotationAnchor (HsProc an a b)         anc cs = (HsProc (setAnchorEpa an anc cs) a b)+  setAnnotationAnchor (HsStatic an a)         anc cs = (HsStatic (setAnchorEpa an anc cs) a)   setAnnotationAnchor a@(HsPragE{})            _ _s = a    exact (HsVar x n) = do@@ -2786,8 +2731,16 @@         printStringAtAA l  "_" >> return ()         printStringAtAA cb "`" >> return ()         return x-  -- exact x@(HsRecSel{})                 = withPpr x-  exact x@(HsOverLabel _ _) = withPpr x+  exact x@(HsOverLabel an src l) = do+    let str = "#" ++ case src of+              NoSourceText   -> (unpackFS l)+              SourceText txt -> txt+    case an of+      EpAnnNotUsed -> printString True str+      EpAnn anc _ _ -> do+        _ <- markAnnotated (L (RealSrcSpan (anchor anc) Strict.Nothing) (fsLit str))+        return ()+    return x    exact x@(HsIPVar _ (HsIPName n))     = printStringAdvance ("?" ++ unpackFS n) >> return x@@ -2822,11 +2775,11 @@     e1' <- markAnnotated e1     e2' <- markAnnotated e2     return (HsApp an e1' e2')-  exact (HsAppType ss fun arg) = do+  exact (HsAppType ss fun at arg) = do     fun' <- markAnnotated fun-    printStringAtSs ss "@"+    at' <- markToken at     arg' <- markAnnotated arg-    return (HsAppType ss fun' arg')+    return (HsAppType ss fun' at' arg')   exact (OpApp an e1 e2 e3) = do     e1' <- markAnnotated e1     e2' <- markAnnotated e2@@ -3004,9 +2957,9 @@    exact (HsUntypedBracket an (DecBrL a e)) = do     an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|")-    an1 <- markEpAnnL an0 lidl AnnOpenC  -- "{"   -- optional+    an1 <- markEpAnnL an0 lidl AnnOpenC     e' <- markAnnotated e-    an2 <- markEpAnnL an1 lidl AnnCloseC -- "}"   -- optional+    an2 <- markEpAnnL an1 lidl AnnCloseC     an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]"     return (HsUntypedBracket an3 (DecBrL a e')) @@ -3028,9 +2981,13 @@         return (an', e')     return (HsUntypedBracket an0 (VarBr a b e')) -  exact (HsSpliceE a sp) = do-    sp' <- markAnnotated sp-    return (HsSpliceE a sp')+  exact (HsTypedSplice (x,an) s)   = do+    an0 <- markEpAnnL an lidl AnnDollarDollar+    s' <- exact s+    return (HsTypedSplice (x,an0) s')+  exact (HsUntypedSplice an s) = do+    s' <- exact s+    return (HsUntypedSplice an s')    exact (HsProc an p c) = do     debugM $ "HsProc start"@@ -3084,41 +3041,30 @@   getAnnotationEntry HsPragSCC{}  = NoEntryVal   setAnnotationAnchor a _ _ = a -  exact (HsPragSCC an st sl) = do+  exact (HsPragSCC (an,st) sl) = do     an0 <- markAnnOpenP an st "{-# SCC"     let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)     an1 <- markEpAnnLMS an0 lapr_rest AnnVal    (Just txt) -- optional     an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional     an3 <- markAnnCloseP an2-    return (HsPragSCC an3 st sl)+    return (HsPragSCC (an3,st) sl)   -- --------------------------------------------------------------------- -instance ExactPrint (HsSplice GhcPs) where-  getAnnotationEntry (HsTypedSplice an _ _ _)   = fromAnn an-  getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an-  getAnnotationEntry (HsQuasiQuote _ _ _ _ _)   = NoEntryVal-  getAnnotationEntry (HsSpliced _ _ _)          = NoEntryVal+instance ExactPrint (HsUntypedSplice GhcPs) where+  getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an+  getAnnotationEntry (HsQuasiQuote _ _ _)       = NoEntryVal -  setAnnotationAnchor (HsTypedSplice an a b c)   anc cs = (HsTypedSplice (setAnchorEpa an anc cs) a b c)-  setAnnotationAnchor (HsUntypedSplice an a b c) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) a b c)-  setAnnotationAnchor a@(HsQuasiQuote _ _ _ _ _) _ _ = a-  setAnnotationAnchor a@(HsSpliced _ _ _)        _ _ = a+  setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e+  setAnnotationAnchor a@HsQuasiQuote {}         _ _ = a -  exact (HsTypedSplice an DollarSplice n e) = do-    an0 <- markEpAnnL an lidl AnnDollarDollar+  exact (HsUntypedSpliceExpr an e) = do+    an0 <- markEpAnnL an lidl AnnDollar     e' <- markAnnotated e-    return (HsTypedSplice an0 DollarSplice n e')--  exact (HsUntypedSplice an decoration n b) = do-    an0 <- if (decoration == DollarSplice)-             then markEpAnnL an lidl AnnDollar-             else return an-    b' <- markAnnotated b-    return (HsUntypedSplice an0 decoration n b')+    return (HsUntypedSpliceExpr an0 e') -  exact (HsQuasiQuote a b q ss fs) = do+  exact (HsQuasiQuote an q (L l fs)) = do     -- The quasiquote string does not honour layout offsets. Store     -- the colOffset for now.     -- TODO: use local?@@ -3129,11 +3075,7 @@             -- Note: Lexer.x does not provide unicode alternative. 2017-02-26             ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]")     unless pMarkLayout $ setLayoutOffsetP oldOffset-    p <- getPosP-    debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss)-    return (HsQuasiQuote a b q ss fs)--  exact x = error $ "exact HsSplice for:" ++ showAst x+    return (HsQuasiQuote an q (L l fs))  -- --------------------------------------------------------------------- @@ -3141,22 +3083,22 @@ instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a-  exact (MG x matches o) = do+  exact (MG x matches) = do     -- TODO:AZ use SortKey, in MG ann.     matches' <- if isGoodSrcSpan (getLocA matches)       then markAnnotated matches       else return matches-    return (MG x matches' o)+    return (MG x matches')  instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a-  exact (MG x matches o) = do+  exact (MG x matches) = do     -- TODO:AZ use SortKey, in MG ann.     matches' <- if isGoodSrcSpan (getLocA matches)       then markAnnotated matches       else return matches-    return (MG x matches' o)+    return (MG x matches')  -- --------------------------------------------------------------------- @@ -3248,19 +3190,12 @@    setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a -#if MIN_VERSION_ghc(9,4,3)-  exact (DotFieldOcc an (L loc fs)) = do+  exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do     an0 <- markLensKwM an lafDot  AnnDot     -- The field name has a SrcSpanAnnN, print it as a     -- LocatedN RdrName     L loc' _ <- markAnnotated (L loc (mkVarUnqual fs))-    return (DotFieldOcc an0 (L loc' fs))-#else-  exact (DotFieldOcc an fs) = do-    an0 <- markLensKwM an lafDot  AnnDot-    fs' <- markAnnotated fs-    return (DotFieldOcc an0 fs')-#endif+    return (DotFieldOcc an0 (L loc' (FieldLabelString fs)))  -- --------------------------------------------------------------------- @@ -3439,10 +3374,7 @@     return (BindStmt an0 pat' body')    exact (ApplicativeStmt _ _body _) = do-    debugM $ "ApplicativeStmt"-    -- TODO: ApplicativeStmt-    -- markAnnotated body-    error $ "need to complete ApplicativeStmt"+    error $ "ApplicativeStmt is introduced in the renamer"    exact (BodyStmt a body b c) = do     debugM $ "BodyStmt"@@ -3466,17 +3398,12 @@     (an', by', using') <- exactTransStmt an by using form     return (TransStmt an' form stmts' b using' by' c d e) -   exact (RecStmt an stmts a b c d e) = do     debugM $ "RecStmt"     an0 <- markEpAnnL an lal_rest AnnRec     (an1, stmts') <- markAnnList True an0 (markAnnotated stmts)     return (RecStmt an1 stmts' a b c d e) -  -- exact x = error $ "exact CmdLStmt for:" ++ showAst x-  -- exact x = error $ "exact CmdLStmt for:"-- -- ---------------------------------------------------------------------  instance ExactPrint (ParStmtBlock GhcPs GhcPs) where@@ -3516,17 +3443,17 @@ -- ---------------------------------------------------------------------  instance ExactPrint (TyClDecl GhcPs) where-  getAnnotationEntry (FamDecl   { })                      = NoEntryVal-  getAnnotationEntry (SynDecl   { tcdSExt = an })         = fromAnn an-  getAnnotationEntry (DataDecl  { tcdDExt = an })         = fromAnn an-  getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an+  getAnnotationEntry (FamDecl   { })                   = NoEntryVal+  getAnnotationEntry (SynDecl   { tcdSExt = an })      = fromAnn an+  getAnnotationEntry (DataDecl  { tcdDExt = an })      = fromAnn an+  getAnnotationEntry (ClassDecl { tcdCExt = (an, _) }) = fromAnn an    setAnnotationAnchor a@FamDecl{}     _ _s = a   setAnnotationAnchor x@SynDecl{}   anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs }   setAnnotationAnchor x@DataDecl{}  anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs }-  setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a, b) }+  setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a) }     where-      (an,a,b) = tcdCExt x+      (an,a) = tcdCExt x    exact (FamDecl a decl) = do     decl' <- markAnnotated decl@@ -3558,7 +3485,8 @@    -- ----------------------------------- -  exact (ClassDecl {tcdCExt = (an, sortKey, lo),+  exact (ClassDecl {tcdCExt = (an, sortKey),+                    tcdLayout = lo,                     tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,                     tcdFixity = fixity,                     tcdFDs  = fds,@@ -3571,7 +3499,8 @@           (an0, fds', lclas', tyvars',context') <- top_matter           an1 <- markEpAnnL an0 lidl AnnOpenC           an2 <- markEpAnnL an1 lidl AnnCloseC-          return (ClassDecl {tcdCExt = (an2, sortKey, lo),+          return (ClassDecl {tcdCExt = (an2, sortKey),+                             tcdLayout = lo,                              tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',                              tcdFixity = fixity,                              tcdFDs  = fds',@@ -3597,7 +3526,8 @@             methods' = listToBag $ undynamic ds             ats'     = undynamic ds             at_defs' = undynamic ds-          return (ClassDecl {tcdCExt = (an3, sortKey, lo),+          return (ClassDecl {tcdCExt = (an3, sortKey),+                             tcdLayout = lo,                              tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars',                              tcdFixity = fixity,                              tcdFDs  = fds',@@ -3724,14 +3654,21 @@             , EpAnn [AddEpAnn] -- ^ updated one passed in             , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs) exactDataDefn an exactHdr-                 (HsDataDefn { dd_ext = x, dd_ND = new_or_data, dd_ctxt = context+                 (HsDataDefn { dd_ext = x, dd_ctxt = context                              , dd_cType = mb_ct                              , dd_kindSig = mb_sig                              , dd_cons = condecls, dd_derivs = derivings }) = do+   an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP]-  an0 <- if new_or_data == DataType-    then markEpAnnL an' lidl AnnData-    else markEpAnnL an' lidl AnnNewtype++  an00 <- if isTypeDataDefnCons condecls+           then markEpAnnL an' lidl AnnType+           else return an'++  an0 <- markEpAnnL an00 lidl $ case condecls of+    DataTypeCons _ _ -> AnnData+    NewTypeCon   _ -> AnnNewtype+   an1 <- markEpAnnL an0 lidl AnnInstance -- optional   mb_ct' <- mapM markAnnotated mb_ct   (anx, ln', tvs', b, mctxt') <- exactHdr context@@ -3741,18 +3678,23 @@       an2 <- markEpAnnL an1 lidl AnnDcolon       kind' <- markAnnotated kind       return (an2, Just kind')-  an3 <- if (isGadt condecls)+  an3 <- if (needsWhere condecls)     then markEpAnnL an2 lidl AnnWhere     else return an2   an4 <- markEpAnnL an3 lidl AnnOpenC-  (an5, condecls') <- exact_condecls an4 condecls+  (an5, condecls') <- exact_condecls an4 (toList condecls)+  let condecls'' = case condecls of+        DataTypeCons d _ -> DataTypeCons d condecls'+        NewTypeCon _     -> case condecls' of+          [decl] -> NewTypeCon decl+          _ -> panic "exacprint NewTypeCon"   an6 <- markEpAnnL an5 lidl AnnCloseC   derivings' <- mapM markAnnotated derivings   return (anx, an6, ln', tvs', b, mctxt',-                 (HsDataDefn { dd_ext = x, dd_ND = new_or_data, dd_ctxt = context+                 (HsDataDefn { dd_ext = x, dd_ctxt = context                              , dd_cType = mb_ct'                              , dd_kindSig = mb_sig'-                             , dd_cons = condecls', dd_derivs = derivings' }))+                             , dd_cons = condecls'', dd_derivs = derivings' }))   exactVanillaDeclHead :: (Monad m, Monoid w)@@ -3980,8 +3922,8 @@     return (HsSpliceTy a splice')   exact (HsDocTy an ty doc) = do     ty' <- markAnnotated ty-    -- doc' <- markAnnotated doc-    return (HsDocTy an ty' doc)+    doc' <- markAnnotated doc+    return (HsDocTy an ty' doc')   exact (HsBangTy an (HsSrcBang mt up str) ty) = do     an0 <-       case mt of@@ -4081,11 +4023,19 @@   setAnnotationAnchor (NewtypeStrategy an)  anc cs = (NewtypeStrategy (setAnchorEpa an anc cs))   setAnnotationAnchor (ViaStrategy (XViaStrategyPs an  a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs)  a)) -  exact s@(StockStrategy an)    = markEpAnn an AnnStock >> return s-  exact s@(AnyclassStrategy an) = markEpAnn an AnnAnyclass >> return s-  exact s@(NewtypeStrategy an)  = markEpAnn an AnnNewtype >> return s-  exact s@(ViaStrategy (XViaStrategyPs an ty))-    = markEpAnn an AnnVia >> markAnnotated ty >> return s+  exact (StockStrategy an)    = do+    an0 <- markEpAnnL an lid AnnStock+    return (StockStrategy an0)+  exact (AnyclassStrategy an) = do+    an0 <- markEpAnnL an lid AnnAnyclass+    return (AnyclassStrategy an0)+  exact (NewtypeStrategy an)  = do+    an0 <- markEpAnnL an lid AnnNewtype+    return (NewtypeStrategy an0)+  exact (ViaStrategy (XViaStrategyPs an ty)) = do+    an0 <- markEpAnnL an lid AnnVia+    ty' <- markAnnotated ty+    return (ViaStrategy (XViaStrategyPs an0 ty'))  -- --------------------------------------------------------------------- @@ -4194,7 +4144,7 @@               s -> s   loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str   case loc of-    EpaSpan _ -> return anc+    EpaSpan _ _ -> return anc     EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp }     EpaDelta _ _cs -> error "printUnicode should not capture comments" @@ -4271,6 +4221,7 @@                     , con_mb_cxt = mcxt                     , con_args = args                     , con_doc = doc }) = do+    doc' <- mapM markAnnotated doc     an0 <- if has_forall       then markEpAnnL an lidl AnnForall       else return an@@ -4290,7 +4241,7 @@                        , con_ex_tvs = ex_tvs'                        , con_mb_cxt = mcxt'                        , con_args = args'-                       , con_doc = doc })+                       , con_doc = doc' })      where     --   -- In ppr_details: let's not print the multiplicities (they are always 1, by@@ -4314,12 +4265,14 @@    exact (ConDeclGADT { con_g_ext = an                      , con_names = cons+                     , con_dcolon = dcol                      , con_bndrs = bndrs                      , con_mb_cxt = mcxt, con_g_args = args                      , con_res_ty = res_ty, con_doc = doc }) = do+    doc' <- mapM markAnnotated doc     cons' <- mapM markAnnotated cons-    an0 <- markEpAnnL an lidl AnnDcolon-    an1 <- annotationsToComments an0 lidl  [AnnOpenP, AnnCloseP]+    dcol' <- markUniToken dcol+    an1 <- annotationsToComments an lidl  [AnnOpenP, AnnCloseP]      -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558     bndrs' <- case bndrs of@@ -4342,9 +4295,10 @@     res_ty' <- markAnnotated res_ty     return (ConDeclGADT { con_g_ext = an2                         , con_names = cons'+                        , con_dcolon = dcol'                         , con_bndrs = bndrs'                         , con_mb_cxt = mcxt', con_g_args = args'-                        , con_res_ty = res_ty', con_doc = doc })+                        , con_res_ty = res_ty', con_doc = doc' })  -- --------------------------------------------------------------------- @@ -4380,7 +4334,8 @@     names' <- markAnnotated names     an0 <- markEpAnnL an lidl AnnDcolon     ftype' <- markAnnotated ftype-    return (ConDeclField an0 names' ftype' mdoc)+    mdoc' <- mapM markAnnotated mdoc+    return (ConDeclField an0 names' ftype' mdoc')  -- --------------------------------------------------------------------- @@ -4476,12 +4431,10 @@     an3 <- markLensMAA an2 lal_close     return (L (la { ann = an3}) a') --- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where-  getAnnotationEntry = entryFromLocatedAFixed+  getAnnotationEntry = entryFromLocatedA   setAnnotationAnchor = setAnchorAn-  exact (L (SrcSpanAnn an' l) stmts) = do-    let an = fixAnnListAnn an'+  exact (L (SrcSpanAnn an l) stmts) = do     debugM $ "LocatedL [ExprLStmt"     (an'', stmts') <- markAnnList True an $ do       case snocView stmts of@@ -4492,16 +4445,13 @@           return (initStmts' ++ [ls'])         _ -> do           markAnnotated stmts-        -- x -> error $ "pprDo:ListComp" ++ showAst x-      -- markLocatedMAA an al_close     return (L (SrcSpanAnn an'' l) stmts')  -- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where-  getAnnotationEntry = entryFromLocatedAFixed+  getAnnotationEntry = entryFromLocatedA   setAnnotationAnchor = setAnchorAn-  exact (L (SrcSpanAnn ann' l) es) = do-    let ann = fixAnnListAnn ann'+  exact (L (SrcSpanAnn ann l) es) = do     debugM $ "LocatedL [CmdLStmt"     an0 <- markLensMAA ann lal_open     es' <- mapM markAnnotated es@@ -4583,24 +4533,17 @@     m' <- markAnnotated m     return (IEModuleContents an0 m') -  -- These three exist to not error out, but are no-ops The contents-  -- appear as "normal" comments too, which we process instead.-  exact (IEGroup x lev doc) = do-    return (IEGroup x lev doc)-  exact (IEDoc x doc) = do-    return (IEDoc x doc)-  exact (IEDocNamed x str) = do-    return (IEDocNamed x str)+  exact x = error $ "missing match for IE:" ++ showAst x  -- --------------------------------------------------------------------- -instance ExactPrint (IEWrappedName RdrName) where+instance ExactPrint (IEWrappedName GhcPs) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a -  exact (IEName n) = do+  exact (IEName x n) = do     n' <- markAnnotated n-    return (IEName n')+    return (IEName x n')   exact (IEPattern r n) = do     r' <- printStringAtAA r "pattern"     n' <- markAnnotated n@@ -4616,7 +4559,7 @@   getAnnotationEntry (WildPat _)              = NoEntryVal   getAnnotationEntry (VarPat _ _)             = NoEntryVal   getAnnotationEntry (LazyPat an _)           = fromAnn an-  getAnnotationEntry (AsPat an _ _)           = fromAnn an+  getAnnotationEntry (AsPat an _ _ _)         = fromAnn an   getAnnotationEntry (ParPat an _ _ _)        = fromAnn an   getAnnotationEntry (BangPat an _)           = fromAnn an   getAnnotationEntry (ListPat an _)           = fromAnn an@@ -4633,7 +4576,7 @@   setAnnotationAnchor a@(WildPat _)              _ _s = a   setAnnotationAnchor a@(VarPat _ _)             _ _s = a   setAnnotationAnchor (LazyPat an a)            anc cs = (LazyPat (setAnchorEpa an anc cs) a)-  setAnnotationAnchor (AsPat an a b)            anc cs = (AsPat (setAnchorEpa an anc cs) a b)+  setAnnotationAnchor (AsPat an a at b)         anc cs = (AsPat (setAnchorEpa an anc cs) a at b)   setAnnotationAnchor (ParPat an a b c)         anc cs = (ParPat (setAnchorEpa an anc cs) a b c)   setAnnotationAnchor (BangPat an a)            anc cs = (BangPat (setAnchorEpa an anc cs) a)   setAnnotationAnchor (ListPat an a)            anc cs = (ListPat (setAnchorEpa an anc cs) a)@@ -4664,11 +4607,11 @@     an0 <- markEpAnnL an lidl AnnTilde     pat' <- markAnnotated pat     return (LazyPat an0 pat')-  exact (AsPat an n pat) = do+  exact (AsPat an n at pat) = do     n' <- markAnnotated n-    an0 <- markEpAnnL an lidl AnnAt+    at' <- markToken at     pat' <- markAnnotated pat-    return (AsPat an0 n' pat')+    return (AsPat an n' at' pat')   exact (ParPat an lpar pat rpar) = do     lpar' <- markToken lpar     pat' <- markAnnotated pat@@ -4742,9 +4685,8 @@   setAnnotationAnchor a _ _ = a    exact (HsPS an ty) = do-    an0 <- markAnnKwL an lid AnnAt     ty' <- markAnnotated ty-    return (HsPS an0 ty')+    return (HsPS an ty')  -- --------------------------------------------------------------------- @@ -4768,9 +4710,7 @@ hsLit2String lit =   case lit of     HsChar       src v   -> toSourceTextWithSuffix src v ""-    -- It should be included here-    -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471-    HsCharPrim   src p   -> toSourceTextWithSuffix src p "#"+    HsCharPrim   src p   -> toSourceTextWithSuffix src p ""     HsString     src v   -> toSourceTextWithSuffix src v ""     HsStringPrim src v   -> toSourceTextWithSuffix src v ""     HsInt        _ (IL src _ v)   -> toSourceTextWithSuffix src v ""@@ -4782,7 +4722,6 @@     HsRat        _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl ""     HsFloatPrim  _ fl@(FL{fl_text = src })   -> toSourceTextWithSuffix src fl "#"     HsDoublePrim _ fl@(FL{fl_text = src })   -> toSourceTextWithSuffix src fl "##"-    -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x  toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText)    alt suffix = show alt ++ suffix@@ -4809,6 +4748,14 @@   an1 <- markEpAnnL an0 lidl AnnCloseC   return (an1, c', details') +instance ExactPrint (HsConPatTyArg GhcPs) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ = a+  exact (HsConPatTyArg at tyarg) = do+    at' <- markToken at+    tyarg' <- markAnnotated tyarg+    return (HsConPatTyArg at' tyarg')+ exactConArgs :: (Monad m, Monoid w)   => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) exactConArgs (PrefixCon tyargs pats) = do@@ -4828,11 +4775,6 @@ entryFromLocatedA :: LocatedAn ann a -> Entry entryFromLocatedA (L la _) = fromAnn la --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256-entryFromLocatedAFixed :: LocatedL a -> Entry-entryFromLocatedAFixed (L la _)-  = fromAnn (fixSrcAnnL la)- -- ===================================================================== -- Utility stuff -- ---------------------------------------------------------------------@@ -5086,7 +5028,6 @@ printStringAdvance :: (Monad m, Monoid w) => String -> EP w m () printStringAdvance str = do   ss <- getAnchorU-  debugM $ "printStringAdvance: ss =" ++ showGhc ss   _ <- printStringAtRs ss str   return () 

@@ -30,7 +30,6 @@       AnnValStr       -> mkErr kw       AnnName         -> mkErr kw       AnnAs           -> "as"-      AnnAt           -> "@"       AnnBang         -> "!"       AnnBackquote    -> "`"       AnnBy           -> "by"

@@ -6,8 +6,14 @@ import GHC hiding (EpaComment)  -- ---------------------------------------------------------------------++-- --------------------------------------------------------------------- -- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372 +{-+instance Default [a] where+  def = []+-} instance Default NameAnn where   def = mempty @@ -37,6 +43,11 @@ instance Default EpAnnUnboundVar where   def = EpAnnUnboundVar def  def +{-+instance (Default a, Default b) => Default (a, b) where+  def = (def, def)+-}+ instance Default NoEpAnns where   def = NoEpAnns @@ -51,6 +62,11 @@  instance Default AnnsIf where   def = AnnsIf def def def def def++{-+instance Default (Maybe a) where+  def = Nothing+-}  instance Default AnnProjection where   def = AnnProjection def def

@@ -47,29 +47,24 @@  import Language.Haskell.GHC.ExactPrint.Preprocess -import Control.Monad.RWS+-- import Control.Monad.RWS+import Data.Functor (void)  import qualified GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString    as GHC import qualified GHC.Data.StringBuffer  as GHC--- import qualified GHC.Driver.Config      as GHC import qualified GHC.Driver.Config.Parser as GHC-import qualified GHC.Driver.Errors.Types  as GHC+import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Session     as GHC import qualified GHC.Parser             as GHC import qualified GHC.Parser.Header      as GHC import qualified GHC.Parser.Lexer       as GHC import qualified GHC.Parser.PostProcess as GHC--- import qualified GHC.Parser.Errors.Ppr  as GHC import qualified GHC.Types.SrcLoc       as GHC--- import qualified GHC.Utils.Error        as GHC  import qualified GHC.LanguageExtensions as LangExt -{-# ANN module "HLint: ignore Eta reduce" #-}-{-# ANN module "HLint: ignore Redundant do" #-}-{-# ANN module "HLint: ignore Reduce duplication" #-} -- ---------------------------------------------------------------------  -- | Wrapper function which returns Annotations along with the parsed@@ -125,7 +120,7 @@  -- --------------------------------------------------------------------- -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule)+parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) parseFile = runParser GHC.parseModule  -- ---------------------------------------------------------------------@@ -281,17 +276,17 @@ fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleTrailingComments (GHC.L l p) = GHC.L l p'   where-    an' = case GHC.hsmodAnn p of+    an' = case GHC.hsmodAnn $ GHC.hsmodExt p of       (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs)       unused -> unused-    p' = p { GHC.hsmodAnn = an' }+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } }     -- p'  = error $ "fixModuleTrailingComments: an'=" ++ showAst an'      rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments     rebalance al cs = cs'       where         cs' = case GHC.al_close al of-          Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) ->+          Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) ->             let               pc = GHC.priorComments cs               fc = GHC.getFollowingComments cs

@@ -18,29 +18,28 @@ import qualified GHC            as GHC hiding (parseModule)  import qualified Control.Monad.IO.Class as GHC-import qualified GHC.Data.Bag          as GHC import qualified GHC.Data.FastString   as GHC import qualified GHC.Data.StringBuffer as GHC--- import qualified GHC.Driver.Config     as GHC-import qualified GHC.Driver.Config.Parser     as GHC+import qualified GHC.Driver.Config.Parser as GHC import qualified GHC.Driver.Env        as GHC-import qualified GHC.Driver.Errors.Types        as GHC+import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases     as GHC import qualified GHC.Driver.Pipeline   as GHC import qualified GHC.Fingerprint.Type  as GHC -- import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer      as GHC import qualified GHC.Settings          as GHC+import qualified GHC.Types.Error       as GHC import qualified GHC.Types.SourceError as GHC-import qualified GHC.Types.SrcLoc      as GHC import qualified GHC.Types.SourceFile  as GHC-import qualified GHC.Types.Error  as GHC--- import qualified GHC.Utils.Error       as GHC+import qualified GHC.Types.SrcLoc      as GHC+import qualified GHC.Utils.Error       as GHC import qualified GHC.Utils.Fingerprint as GHC+import qualified GHC.Utils.Outputable  as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) -import Data.List (isPrefixOf, intercalate)+import Data.List (isPrefixOf) import Data.Maybe import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils@@ -49,9 +48,6 @@  -- import Debug.Trace ---{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}-{-# ANN module ("HLint: ignore Redundant do" :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}  -- --------------------------------------------------------------------- @@ -130,9 +126,8 @@ goodComment :: GHC.LEpaComment -> Bool goodComment c = isGoodComment (tokComment c)   where-    isGoodComment :: [Comment] -> Bool-    isGoodComment []                 = False-    isGoodComment [Comment "" _ _ _] = False+    isGoodComment :: Comment -> Bool+    isGoodComment (Comment "" _ _ _) = False     isGoodComment _                  = True  @@ -225,25 +220,19 @@       new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs }   r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile))   case r of-    Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err+    Left err -> error $ showErrorMessages err     Right (dflags', hspp_fn) -> do       buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn       txt <- GHC.liftIO $ readFileGhc hspp_fn       return (txt, buf, dflags') -showErrorMessages :: GHC.ErrorMessages -> String-showErrorMessages msgs = intercalate "\n"-    $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage)-    $ GHC.bagToList-    $ GHC.getErrorMessages msgs---- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage--- We convert a known Diagnostic into this generic version-toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage-toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg-                                                , diagReason  = GHC.diagnosticReason  msg-                                                , diagHints   = GHC.diagnosticHints   msg-                                                }+showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String+showErrorMessages msgs =+  GHC.renderWithContext GHC.defaultSDocContext+    $ GHC.vcat+    $ GHC.pprMsgEnvelopeBagWithLocDefault+    $ GHC.getMessages+    $ msgs  injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags =

@@ -88,6 +88,7 @@ import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils+-- import Language.Haskell.GHC.ExactPrint.Orphans (Default(..))  import Control.Monad.RWS import qualified Control.Monad.Fail as Fail@@ -96,13 +97,14 @@ import GHC.Data.Bag import GHC.Data.FastString +import Data.Data+import Data.Default import Data.Maybe import Data.Generics import Data.List (sortBy)  import Data.Functor.Identity import Control.Monad.State-import Data.Default  ------------------------------------------------------------------------------ -- Transformation of source elements@@ -117,7 +119,6 @@                          ,MonadReader ()                          ,MonadWriter [String]                          ,MonadState Int-                         ,MonadTrans                          )  instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where@@ -184,8 +185,8 @@ -- ---------------------------------------------------------------------  captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs-captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f)))-                       = L l (ValD x (FunBind a b (MG c (L d ms') e) f))+captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))+                       = L l (ValD x (FunBind a b (MG c (L d ms'))))     where       ms' :: [LMatch GhcPs (LHsExpr GhcPs)]       ms' = captureLineSpacing ms@@ -214,7 +215,7 @@       L (SrcSpanAnn EpAnnNotUsed   ll) _ -> realSrcSpan ll       L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?     dc' = case dca of-      EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])+      EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])       EpaDelta _ _ -> AddEpAnn kw dca      -- ---------------------------------@@ -224,7 +225,7 @@       (L (SrcSpanAnn EpAnnNotUsed    ll) b)         -> let              op = case dca of-               EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))+               EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))                EpaDelta _ _ -> MovedAnchor (SameLine 1)            in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b)       (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b)@@ -232,7 +233,7 @@               op' = case op of                 MovedAnchor _ -> op                 _ -> case dca of-                  EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r)+                  EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r)                   EpaDelta _ _ -> MovedAnchor (SameLine 1)            in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) @@ -269,8 +270,8 @@ -- ---------------------------------------------------------------------  setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs-setEntryDPDecl decl@(L _  (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp-                   = L l' (ValD x (FunBind a b (MG c (L d ms') e) f))+setEntryDPDecl decl@(L _  (ValD x (FunBind a b (MG c (L d ms ))))) dp+                   = L l' (ValD x (FunBind a b (MG c (L d ms'))))     where       L l' _ = setEntryDP decl dp       ms' :: [LMatch GhcPs (LHsExpr GhcPs)]@@ -342,13 +343,13 @@  addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs-addEpaLocationDelta  off  anc (EpaSpan r)+addEpaLocationDelta  off  anc (EpaSpan r _)   = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []  -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a-setEntryDPFromAnchor  off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp'+setEntryDPFromAnchor  off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp'   where     r = case la of       (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l@@ -399,8 +400,8 @@   pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs-pushDeclDP (ValD x (FunBind a b (MG c (L d  ms ) e) f)) dp-          = ValD x (FunBind a b (MG c (L d' ms') e) f)+pushDeclDP (ValD x (FunBind a b (MG c (L d  ms )))) dp+          = ValD x (FunBind a b (MG c (L d' ms')))     where       L d' _ = setEntryDP (L d ms) dp       ms' :: [LMatch GhcPs (LHsExpr GhcPs)]@@ -412,20 +413,14 @@ -- ---------------------------------------------------------------------  balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]-balanceCommentsList [] = return []-balanceCommentsList [x] = return [x]-balanceCommentsList (a:b:ls) = do-  (a',b') <- balanceComments a b-  r <- balanceCommentsList (b':ls)-  return (a':r)+balanceCommentsList ds = balanceCommentsList'' ds -balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a]-balanceCommentsList' [] = return []-balanceCommentsList' [x] = return [x]-balanceCommentsList' (a:b:ls) = do-  logTr $ "balanceCommentsList' entered"-  (a',b') <- balanceComments' a b-  r <- balanceCommentsList' (b':ls)+balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]+balanceCommentsList'' [] = return []+balanceCommentsList'' [x] = return [x]+balanceCommentsList'' (a:b:ls) = do+  (a',b') <- balanceComments a b+  r <- balanceCommentsList'' (b':ls)   return (a':r)  -- |The GHC parser puts all comments appearing between the end of one AST@@ -449,7 +444,7 @@ -- 'Match' if that 'Match' needs to be manipulated. balanceCommentsFB :: (Monad m)   => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b)-balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do+balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do   logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf)   -- There are comments on lf.  We need to   -- + Keep the prior ones here@@ -480,7 +475,7 @@         [] -> moveLeadingComments m'' lf'         _  -> (m'',lf')   logTr $ "balanceCommentsMatch done"-  balanceComments' (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t)) second'+  balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second' balanceCommentsFB f s = balanceComments' f s  -- | Move comments on the same line as the end of the match into the@@ -536,6 +531,15 @@       _ -> (ValBinds NoAnnSortKey emptyBag [], [])  +balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a]+balanceCommentsList' [] = return []+balanceCommentsList' [x] = return [x]+balanceCommentsList' (a:b:ls) = do+  logTr $ "balanceCommentsList' entered"+  (a',b') <- balanceComments' a b+  r <- balanceCommentsList' (b':ls)+  return (a':r)+ -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided@@ -544,29 +548,26 @@ -- Many of these should in fact be following comments for the previous anchor balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) balanceComments' la1 la2 = do-  -- logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)-  -- logTr $ "balanceComments': (anc1)=" ++ showAst (anc1)-  -- logTr $ "balanceComments': (cs2p)=" ++ showAst (cs2p)-  -- logTr $ "balanceComments': (cs2f)=" ++ showAst (cs2f)-  -- logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)-  -- logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')+  logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2)+  logTr $ "balanceComments': (anc1)=" ++ showAst (anc1)+  logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s)+  logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move)+  logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2')   return (la1', la2')   where     simpleBreak n (r,_) = r > n-    L (SrcSpanAnn an1 _loc1) f = la1-    L (SrcSpanAnn an2 _loc2) s = la2+    L (SrcSpanAnn an1 loc1) f = la1+    L (SrcSpanAnn an2 loc2) s = la2     anc1 = addCommentOrigDeltas $ epAnnComments an1     anc2 = addCommentOrigDeltas $ epAnnComments an2 -    -- Split comments into those before the span, in the span, and after the span-    (cs1prior,cs1m,cs1following) = splitCommentsAround (anchorFromLocatedA la1) anc1-    cs1p = priorCommentsDeltas    (anchorFromLocatedA la1) cs1prior-    cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) cs1following+    cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1+    cs1p = priorCommentsDeltas    (anchorFromLocatedA la1) (priorComments        cs1s)+    cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1s) -    -- Split comments into those before the span, in the span, and after the span-    (cs2prior,cs2m,cs2following) = splitCommentsAround (anchorFromLocatedA la2) anc2-    cs2p = priorCommentsDeltas    (anchorFromLocatedA la2) cs2prior-    cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) cs2following+    cs2s = splitCommentsEnd (anchorFromLocatedA la2) anc2+    cs2p = priorCommentsDeltas    (anchorFromLocatedA la2) (priorComments        cs2s)+    cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) (getFollowingComments cs2s)      -- Split cs1f into those that belong on an1 and ones that must move to an2     (cs1move,cs1stay) = break (simpleBreak 1) cs1f@@ -578,12 +579,11 @@     move = sortEpaComments $ map snd (cs1move ++ move'' ++ move')     stay = sortEpaComments $ map snd (cs1stay ++ stay') -    an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced ((map snd cs1p)++cs1m) move)-    an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced (cs2m++stay) (map snd cs2f))+    an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move)+    an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f))     la1' = L an1' f     la2' = L an2' s - -- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]                -> [(Int, LEpaComment)]@@ -631,7 +631,6 @@     cs' = before     ts' = after <> ts - -- | Split comments into ones occuring before the start of the reference -- span, and those after it. splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments@@ -649,21 +648,6 @@     cs' = before     ts' = after <> ts ---- | Split comments into ones occuring before the start of the reference--- span, those in the span, and those after it.-splitCommentsAround :: RealSrcSpan -> EpAnnComments-                    -> ([LEpaComment], [LEpaComment], [LEpaComment])-splitCommentsAround p cs = (before,middle,after)-  where-    all_comments = priorComments cs ++ getFollowingComments cs-    cmpbefore (L (Anchor l _) _) = ss2pos l > ss2pos p-    cmpafter (L (Anchor l _) _) = ss2pos l > ss2posEnd p-    (before, both) = break cmpbefore all_comments-    (middle, after) = break cmpafter both---- ---------------------------------------------------------------------- moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u)   => LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u) moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to)@@ -771,7 +755,7 @@ -- ---------------------------------------------------------------------  anchorEof :: ParsedSource -> ParsedSource-anchorEof (L l m@(HsModule an _lo _mn _exps _imps _decls _ _)) = L l (m { hsmodAnn = an' })+anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } })   where     an' = addCommentOrigDeltasAnn an @@ -911,12 +895,12 @@ -- ---------------------------------------------------------------------  instance HasDecls ParsedSource where-  hsDecls (L _ (HsModule _ _lo _mn _exps _imps decls _ _)) = return decls-  replaceDecls (L l (HsModule a lo mname exps imps _decls deps haddocks)) decls+  hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = return decls+  replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls     = do         logTr "replaceDecls LHsModule"         -- modifyAnnsT (captureOrder m decls)-        return (L l (HsModule a lo mname exps imps decls deps haddocks))+        return (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls))  -- --------------------------------------------------------------------- @@ -962,7 +946,7 @@               (L (TokenLoc l) ls, L (TokenLoc i) is) ->                 let                   off = case l of-                          (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r+                          (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r                           (EpaDelta (SameLine _) _) -> LayoutStartCol 0                           (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c                   ex'' = setEntryDPFromAnchor off i ex@@ -1001,7 +985,7 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]-hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb+hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x  -- -------------------------------------@@ -1023,11 +1007,11 @@ -- idempotent. replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs]                     -> TransformT m (LHsBind GhcPs)-replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls+replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls     = do         logTr "replaceDecls PatBind"         binds'' <- replaceDeclsValbinds WithWhere binds newDecls-        return (L l (PatBind x a (GRHSs xr rhss binds'') b))+        return (L l (PatBind x a (GRHSs xr rhss binds''))) replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x  -- ---------------------------------------------------------------------

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -17,28 +18,29 @@   -- , isGoodDelta   -- ) where   where-import Control.Monad.State++import Control.Monad (when) import Data.Function import Data.List import Data.Maybe import Data.Ord (comparing)  import Language.Haskell.GHC.ExactPrint.Lookup-import Language.Haskell.GHC.ExactPrint.Orphans () +import qualified Language.Haskell.GHC.ExactPrint.Orphans()+ import GHC hiding (EpaComment) import qualified GHC import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc+import GHC.Driver.Ppr import GHC.Data.FastString-import GHC.Utils.Outputable ( showPprUnsafe ) import qualified GHC.Data.Strict as Strict  import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types import Data.Default-import GHC.Base (NonEmpty(..))  -- --------------------------------------------------------------------- @@ -116,7 +118,7 @@     fc = co + dc  undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn-undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp)+undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing)   where     (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)     len = length (keywordToString kw)@@ -180,22 +182,28 @@  -- --------------------------------------------------------------------- -isGadt :: [LConDecl (GhcPass p)] -> Bool-isGadt [] = True-isGadt ((L _ (ConDeclGADT{})):_) = True-isGadt _ = False+isListComp :: HsDoFlavour -> Bool+isListComp = isDoComprehensionContext  -- --------------------------------------------------------------------- +needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool+needsWhere (NewTypeCon _) = True+needsWhere (DataTypeCons _ []) = True+needsWhere (DataTypeCons _ ((L _ (ConDeclGADT{})):_)) = True+needsWhere _ = False++-- ---------------------------------------------------------------------+ insertCppComments ::  ParsedSource -> [LEpaComment] -> ParsedSource insertCppComments (L l p) cs = L l p'   where-    an' = case GHC.hsmodAnn p of+    an' = case GHC.hsmodAnn $ GHC.hsmodExt p of       (EpAnn a an ocs) -> EpAnn a an (EpaComments cs')         where           cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs       unused -> unused-    p' = p { GHC.hsmodAnn = an' }+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }  -- --------------------------------------------------------------------- @@ -206,56 +214,8 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _))    = s ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _))        = "" -tokComment :: LEpaComment -> [Comment]-tokComment t@(L lt c) =-  case c of-    (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc-    _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]--hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]-hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) =-  let-    decStr = printDecorator dec-    L lx x' = dedentDocChunkBy (3 + length decStr) x-    str = "-- " ++ decStr ++ unpackHDSC x'-    docChunk _ [] = []-    docChunk pt' (L l chunk:cs)-      = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs-  in-    (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs))-hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk))-  = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]-hsDocStringComments anc pt (NestedDocString dec (L _ chunk))-  = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ]-hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code---- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed--- At the moment the locations of the 'HsDocStringChunk's are from the start of--- the string part, leaving aside the "--". So we need to subtract 2 columns from it-dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk-dedentDocChunk chunk = dedentDocChunkBy 2 chunk--dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk-dedentDocChunkBy  dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c-  where-    f = srcSpanFile l-    sl = srcSpanStartLine l-    sc = srcSpanStartCol l-    el = srcSpanEndLine l-    ec = srcSpanEndCol l-    l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent))-                       (mkRealSrcLoc f el (ec - dedent))--dedentDocChunkBy _ x = x---- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed-printDecorator :: HsDocStringDecorator -> String-printDecorator HsDocStringNext = "|"-printDecorator HsDocStringPrevious = "^"-printDecorator (HsDocStringNamed n) = '$':n-printDecorator (HsDocStringGroup n) = replicate n '*'--+tokComment :: LEpaComment -> Comment+tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)  mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments mkEpaComments priorCs []@@ -295,7 +255,7 @@  -- | Makes a comment which originates from a specific keyword. mkKWComment :: AnnKeywordId -> EpaLocation -> Comment-mkKWComment kw (EpaSpan ss)+mkKWComment kw (EpaSpan ss _)   = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw) mkKWComment kw (EpaDelta dp _)   = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)@@ -385,17 +345,17 @@  setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an setAnchorEpa EpAnnNotUsed   anc cs = EpAnn anc def cs-setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an     cs+setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an          cs  setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList setAnchorEpaL EpAnnNotUsed   anc cs = EpAnn anc mempty cs setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs -setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule-setAnchorHsModule hsmod anc cs = hsmod { hsmodAnn = an' }+setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs+setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }   where     anc' = anc { anchor_op = UnchangedAnchor }-    an' = setAnchorEpa (hsmodAnn hsmod) anc' cs+    an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs  -- |Version of l2l that preserves the anchor, immportant if it has an -- updated AnchorOperation@@ -422,7 +382,7 @@  -- TODO: move this to GHC anchorToEpaLocation :: Anchor -> EpaLocation-anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r+anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []  -- ---------------------------------------------------------------------

@@ -28,24 +28,25 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC92-           | GHC94+data GHCVersion = GHC94+           | GHC96      deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion-#if MIN_VERSION_ghc(9,4,0)-ghcVersion = GHC94+#if MIN_VERSION_ghc(9,6,0)+ghcVersion = GHC96 #else-ghcVersion = GHC92+ghcVersion = GHC94 #endif  -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs =   case ghcVersion of-    GHC92  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92"]     GHC94  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94"]-    -- GHC94  -> ["ghc94"]+    GHC96  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96"]+    -- GHC96  -> ["ghc96"]+    -- GHC96  -> ["ghc96-copied"]  -- --------------------------------------------------------------------- @@ -144,13 +145,13 @@   return $ TestList [                       internalTests,                       roundTripTests-                    ,-                      (transformTests libdir)-                    , (failingTests libdir)-                    ,-                      roundTripBalanceCommentsTests-                    ,-                      roundTripMakeDeltaTests+                   ,+                     (transformTests libdir)+                   , (failingTests libdir)+                   ,+                     roundTripBalanceCommentsTests+                   ,+                     roundTripMakeDeltaTests                     ]  -- Tests that are no longer needed@@ -242,17 +243,11 @@     -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"     -- mkParserTestMD libdir "ghc92" "TopLevelSemis.hs" -    -- mkParserTest libdir "ghc92" "TopLevelSemis1.hs"-    -- mkParserTestBC libdir "ghc92" "TopLevelSemis1.hs"-    -- mkParserTestMD libdir "ghc92" "TopLevelSemis1.hs" -    -- mkParserTest libdir "ghc94" "Haddock.hs"--    -- mkParserTest libdir "ghc94" "Haddock1.hs"-    -- mkParserTestBC libdir "ghc94" "Haddock1.hs"+    -- mkParserTest libdir "ghc96" "T11671_run.hs" -    -- mkParserTest libdir "ghc94" "HsDocTy.hs"-    mkParserTestBC libdir "ghc94" "HsDocTy.hs"+    -- mkParserTest libdir "ghc96" "LexerM.hs"+    mkParserTestBC libdir "ghc96" "LexerM.hs"     -- Needs GHC changes 

@@ -164,7 +164,7 @@  runRoundTrip :: LibDir              -> Changer-             -> GHC.Located GHC.HsModule+             -> GHC.Located (GHC.HsModule GHC.GhcPs)              -> [GHC.LEpaComment]              -> IO (String, GHC.ParsedSource) runRoundTrip libdir f !parsedOrig cs = do

@@ -21,10 +21,12 @@   , failuresHtmlFile   ) where +import Control.Monad+import Control.Monad.Extra import Data.List hiding (find)-import System.FilePath-import System.FilePath.Find import qualified GHC.Data.StringBuffer as GHC+import System.Directory+import System.FilePath  -- --------------------------------------------------------------------- @@ -100,30 +102,38 @@  -- Given base directory finds all haskell source files findSrcFiles :: FilePath -> IO [FilePath]-findSrcFiles = find filterDirectory filterFilename--filterDirectory :: FindClause Bool-filterDirectory =-  p <$> fileName+findSrcFiles = traverseDir okDirectory accFile []   where-    p x-      | "." `isPrefixOf` x = False+    okDirectory :: FilePath -> Bool+    okDirectory path+      | "." `isPrefixOf` takeBaseName path = False       | otherwise = True -filterFilename :: FindClause Bool-filterFilename = do-  ext <- extension-  fname <- fileName-  return (ext == ".hs" && p fname)-  where-    p x-      | "refactored" `isInfixOf` x = False-      | "Setup.hs" `isInfixOf` x = False-      | "HLint.hs" `isInfixOf` x = False -- HLint config files-      | otherwise                 = True+    accFile :: [FilePath] -> FilePath -> IO [FilePath]+    accFile acc fileName = do+      return (if (takeExtension fileName == ".hs" && p fileName)+                then fileName:acc+                else acc)+      where+        p x+          | "refactored" `isInfixOf` x = False+          | "Setup.hs" `isInfixOf` x = False+          | "HLint.hs" `isInfixOf` x = False -- HLint config files+          | otherwise                 = True  -- ---------------------------------------------------------------------+-- Based on https://stackoverflow.com/questions/51712083/recursively-search-directories-for-all-files-matching-name-criteria-in-haskell+traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b+traverseDir validDir transition =+    let go state dirPath =+            do names <- listDirectory dirPath+               let paths = map (dirPath </>) names+               (dirPaths, filePaths) <- partitionM doesDirectoryExist paths+               state' <- foldM transition state filePaths -- process current dir+               foldM go state' (filter validDir dirPaths) -- process subdirs+     in go +-- --------------------------------------------------------------------- readFileGhc :: FilePath -> IO String readFileGhc file = do   buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file

@@ -11,7 +11,6 @@ -- import Data.Data (Data, toConstr, showConstr, cast) -- import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List-import Data.Maybe -- import Data.Ord (comparing) -- import qualified Data.ByteString as B @@ -88,15 +87,13 @@                    -> [GHC.LEpaComment]                    -> IO (ParseResult GHC.ParsedSource) runPrettyRoundTrip libdir origFile !parsedOrig _cs = do-  -- let !newAnns = addAnnotationsForPretty [] parsedOrig mempty-  let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig-  -- let comments = map tokComment $ GHC.sortRealLocated priorComments-  let comments = concatMap tokComment priorComments+  let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn+        $ GHC.hsmodExt $ GHC.unLoc parsedOrig+  let comments = map tokComment priorComments   let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments   let pragmaStr = intercalate "\n" $ map commentContents pragmas    let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig-  -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig)    parseString libdir origFile printed parsedOrig 

@@ -423,12 +423,11 @@   let       newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5)       doAddLocal = do-        -- decls0 <- hsDecls (makeDeltaAst lp)         decls0 <- hsDecls lp         [de1'',d2] <- balanceCommentsList decls0          let de1 = captureMatchLineSpacing de1''-        let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1+        let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1         let [ma1,_ma2] = ms          (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do@@ -619,8 +618,8 @@           [L li imp1,imp2] = hsmodImports p           n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))           n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))-          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))-          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))           impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0)                                      (AnnList Nothing                                               (Just (AddEpAnn AnnOpenP  d1))@@ -628,7 +627,7 @@                                               [(AddEpAnn AnnHiding d1)]                                               [])                                        emptyComments) l0) [v1,v2]-          imp1' = imp1 { ideclHiding = Just (True,impHiding)}+          imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)}           p' = p { hsmodImports = [L li imp1',imp2]}         return (L l p') @@ -644,7 +643,7 @@         l2 <- uniqueSrcSpanT         let           [L li imp1] = hsmodImports p-          Just (_,L lh ns) = ideclHiding imp1+          Just (_,L lh ns) = ideclImportList imp1           lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m1)                                      (AnnList Nothing                                               (Just (AddEpAnn AnnOpenP  d1))@@ -654,11 +653,11 @@                                        emptyComments) (locA lh))           n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1"))           n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2"))-          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1)))-          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2)))+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))           L ln n = last ns           n' = L (addComma ln) n-          imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))}+          imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))}           p' = p { hsmodImports = [L li imp1']}         return (L l p') 

@@ -1,408 +0,0 @@-{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-}--------------------------------------------------------------------------------- |--- Module      :  Test--- Copyright   :  (c) Simon Marlow 2002--- License     :  BSD-style------ Maintainer  :  libraries@haskell.org--- Stability   :  provisional--- Portability :  portable------ This module illustrates & tests most of the features of Haddock.--- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'.------------------------------------------------------------------------------------- This is plain comment, ignored by Haddock.--module Haddock (--        -- Section headings are introduced with '-- *':-        -- * Type declarations--        -- Subsection headings are introduced with '-- **' and so on.-        -- ** Data types-        T(..), T2, T3(..), T4(..), T5(..), T6(..),-        N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..),--        -- ** Records-        R(..), R1(..),--        -- | test that we can export record selectors on their own:-        p, q, u,--        -- * Class declarations-        C(a,b), D(..), E, F(..),--        -- | Test that we can export a class method on its own:-        a,--        -- * Function types-        f, g,--        -- * Auxiliary stuff--        -- $aux1--        -- $aux2--        -- $aux3--        -- $aux4--        -- $aux5--        -- $aux6--        -- $aux7--        -- $aux8--        -- $aux9--        -- $aux10--        -- $aux11--        -- $aux12--        -- | This is some inline documentation in the export list-        ---        -- > a code block using bird-tracks-        -- > each line must begin with > (which isn't significant unless it-        -- > is at the beginning of the line).--        -- * A hidden module-        module Hidden,--        -- * A visible module-        module Visible,--        {-| nested-style doc comments -}--        -- * Existential \/ Universal types-        Ex(..),--        -- * Type signatures with argument docs-        k, l, m, o,--        -- * A section-        -- and without an intervening comma:-        -- ** A subsection--{-|- > a literal line-- $ a non /literal/ line $--}--        f',-   ) where--import Hidden-import Visible---- | This comment applies to the /following/ declaration--- and it continues until the next non-comment line-data T a b- = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor- | -- | This comment describes the 'B' constructor-   B (T a b, T Int Float) -- ^---- | An abstract data declaration-data T2 a b = T2 a b---- | A data declaration with no documentation annotations on the constructors-data T3 a b = A1 a | B1 b---- A data declaration with no documentation annotations at all-data T4 a b = A2 a | B2 b---- A data declaration documentation on the constructors only-data T5 a b-  = A3 a -- ^ documents 'A3'-  | B3 b -- ^ documents 'B3'---- | Testing alternative comment styles-data T6-  -- | This is the doc for 'A4'-  = A4-  | B4-  | -- ^ This is the doc for 'B4'--    -- | This is the doc for 'C4'-    C4---- | A newtype-newtype N1 a = N1 a---- | A newtype with a fieldname-newtype N2 a b = N2 {n :: a b}---- | A newtype with a fieldname, documentation on the field-newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field-                    }---- | An abstract newtype - we show this one as data rather than newtype because--- the difference isn\'t visible to the programmer for an abstract type.-newtype N4 a b = N4 a--newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor-                    }--newtype N6 a b = N6 {n6 :: a b-                    }-                 -- ^ docs on the constructor only---- | docs on the newtype and the constructor-newtype N7 a b = N7 {n7 :: a b-                    }-                -- ^ The 'N7' constructor---class (D a) => C a  where-   -- |this is a description of the 'a' method-   a :: IO a-   b :: [a]-   -- ^ this is a description of the 'b' method-   c :: a -- c is hidden in the export list---- ^ This comment applies to the /previous/ declaration (the 'C' class)--class D a where-   d :: T a b-   e :: (a,a)--- ^ This is a class declaration with no separate docs for the methods--instance D Int where-  d = undefined-  e = undefined---- instance with a qualified class name-instance Test.D Float where-  d = undefined-  e = undefined--class E a where-  ee :: a--- ^ This is a class declaration with no methods (or no methods exported)---- This is a class declaration with no documentation at all-class F a where-  ff :: a---- | This is the documentation for the 'R' record, which has four fields,--- 'p', 'q', 'r', and 's'.-data R =-  -- | This is the 'C1' record constructor, with the following fields:-  C1 { p :: Int -- ^ This comment applies to the 'p' field-     , q :: forall a . a->a  -- ^ This comment applies to the 'q' field-     , -- | This comment applies to both 'r' and 's'-       r,s :: Int-     }-  | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (),-       u,v :: Int-     }-  -- ^ This is the 'C2' record constructor, also with some fields:---- | Testing different record commenting styles-data R1-  -- | This is the 'C3' record constructor-  = C3 {-        -- | The 's1' record selector-          s1 :: Int-        -- | The 's2' record selector-        , s2 :: Int-        , s3 :: Int  -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here.-                     -- Since GHC doesn't allow that, I have removed it in this file.-        -- ^ The 's3' record selector-     }---- These section headers are only used when there is no export list to--- give the structure of the documentation:---- * This is a section header (level 1)--- ** This is a section header (level 2)--- *** This is a section header (level 3)--{-|-In a comment string we can refer to identifiers in scope with-single quotes like this: 'T', and we can refer to modules by-using double quotes: "Foo".  We can add emphasis /like this/.--   * This is a bulleted list--   - This is the next item (different kind of bullet)--   (1) This is an ordered list--   2. This is the next item (different kind of bullet)--@-     This is a block of code, which can include other markup: 'R'-     formatting-               is-                 significant-@--> this is another block of code--We can also include URLs in documentation: <http://www.haskell.org/>.--}--f :: C a => a -> Int---- | we can export foreign declarations too-foreign import ccall "header.h" g :: Int -> IO CInt---- | this doc string has a parse error in it: \'-h :: Int-h = 42----- $aux1 This is some documentation that is attached to a name ($aux1)--- rather than a source declaration.  The documentation may be--- referred to in the export list using its name.------ @ code block in named doc @---- $aux2 This is some documentation that is attached to a name ($aux2)---- $aux3--- @ code block on its own in named doc @---- $aux4------ @ code block on its own in named doc (after newline) @--{- $aux5 a nested, named doc comment--   with a paragraph,--   @ and a code block @--}---- some tests for various arrangements of code blocks:--{- $aux6->test->test1--@ test2-  test3-@--}--{- $aux7-@-test1-test2-@--}--{- $aux8->test3->test4--}--{- $aux9-@-test1-test2-@-->test3->test4--}--{- $aux10->test3->test4--@-test1-test2-@--}---- This one is currently wrong (Haddock 0.4).  The @...@ part is--- interpreted as part of the bird-tracked code block.-{- $aux11-aux11:-->test3->test4--@-test1-test2-@--}---- $aux12--- > foo------ > bar------- | A data-type using existential\/universal types-data Ex a-  = forall b . C b => Ex1 b-  | forall b . Ex2 b-  | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file-  | Ex4 (forall a . a -> a)---- | This is a function with documentation for each argument-k :: T () ()      -- ^ This argument has type 'T'-  -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int'-  -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@-  -> T5 () ()     -- ^ This argument has a very long description that should-                  -- hopefully cause some wrapping to happen when it is finally-                  -- rendered by Haddock in the generated HTML page.-  -> IO ()        -- ^ This is the result type---- This function has arg docs but no docs for the function itself-l :: (Int, Int, Float) -- ^ takes a triple-  -> Int -- ^ returns an 'Int'---- | This function has some arg docs-m :: R-  -> N1 ()      -- ^ one of the arguments-  -> IO Int     -- ^ and the return value---- | This function has some arg docs but not a return value doc---- can't use the original name ('n') with GHC-newn :: R               -- ^ one of the arguments, an 'R'-     -> N1 ()           -- ^ one of the arguments-     -> IO Int-newn = undefined----- | A foreign import with argument docs-foreign import ccall unsafe "header.h"- o :: Float  -- ^ The input float-   -> IO Float  -- ^ The output float---- | We should be able to escape this: \#\#\#---- p :: Int--- can't use the above original definition with GHC-newp :: Int-newp = undefined---- | a function with a prime can be referred to as 'f''--- but f' doesn't get link'd 'f\''-f' :: Int----- Add some definitions here so that this file can be compiled with GHC--data T1-f = undefined-f' = undefined-type CInt = Int-k = undefined-l = undefined-m = undefined

@@ -1,23 +0,0 @@-{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-}--- | Haddock comment,--- coming before the module-module Haddock1 (--        -- | This is some inline documentation in the export list-        ---        -- > a code block using bird-tracks-        -- > each line must begin with > (which isn't significant unless it-        -- > is at the beginning of the line).-        f--        {-| nested-style doc comments -}-        , g--   ) where---- | Haddock before imports-import Data.List---- | Haddock before decl-f = undefined-g = undefined

@@ -0,0 +1,3 @@+module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where++stdin = "stdin"

@@ -0,0 +1,13 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE DataKinds, TypeData #-}+module T22315a.Lib where++data TermLevel = Mk+type data TypeLevel = Mk++class C (a :: TypeLevel)+instance C Mk where++foo :: C a => proxy a -> ()+foo _ = ()+

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedLabels, FlexibleContexts, OverloadedStrings, RecursiveDo, TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module Main where+++main :: IO ()+main = do+  Gtk.applicationNew (Just "de.weltraumschlangen.reflex-test") []+    >>= maybe+    (die "Failed to initialize GTK")+    ( \application -> do+        ret <- runReflexGtk application (Just argv) $ do+          runGtk $ do+            #add mainWindow+            #packStart outerBox++    )+++            -- #add mainWindow+            -- #packStart outerBox

@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels      #-}+{-# LANGUAGE MagicHash             #-}++import Data.Foldable (traverse_)+import Data.Proxy (Proxy(..))+import GHC.OverloadedLabels (IsLabel(..))+import GHC.TypeLits (KnownSymbol, symbolVal)+import GHC.Prim (Addr#)++instance KnownSymbol symbol => IsLabel symbol String where+  fromLabel = symbolVal (Proxy :: Proxy symbol)++(#), (#.) :: String -> Int -> String+(#) _ i = show i+_ #. i = show i++f :: Addr# -> Int -> String+f _ i = show i++main :: IO ()+main = traverse_ putStrLn+  [ #a+  , #number17+  , #do+  , #type+  , #Foo+  , #3+  , #"199.4"+  , #17a23b+  , #f'a'+  , #'a'+  , #'+  , #''notTHSplice+  , #"..."+  , #привет+  , #こんにちは+  , #"3"+  , #":"+  , #"Foo"+  , #"The quick brown fox"+  , #"\""+  , (++) #hello#world+  , (++) #"hello"#"world"+  , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1`+  , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2`+  ]

@@ -0,0 +1,10 @@+{-# LANGUAGE TypeData #-}+module T22315b where++data TermLevel = Mk+type data TypeLevel = Mk++mk = Mk++type Mk2 = Mk+

@@ -0,0 +1,28 @@+{-# LANGUAGE TypeData, DataKinds, TypeFamilies #-}+module Main where++import Type.Reflection+import Data.Type.Equality++data Proxy a+type data X1 = T -- defines type constructor T+data X2 = T      -- defines type constructor 'T++data family F p++newtype instance F (Proxy T) = ID (forall a. a -> a)+newtype instance F (Proxy 'T) = UC (forall a b. a -> b)++-- This should fail at runtime because these are different types+eq :: T :~~: 'T+Just eq = eqTypeRep typeRep typeRep++p :: a :~~: b -> F (Proxy a) :~: F (Proxy b)+p HRefl = Refl++uc :: a -> b+uc = case castWith (p eq) (ID id) of UC a -> a++main :: IO ()+main = print (uc 'a' :: Int)+

@@ -0,0 +1,10 @@+-- Check that a quoted data type declaration is printed correctly+{-# LANGUAGE TemplateHaskellQuotes, TypeData #-}++module Main where++import Language.Haskell.TH+import Language.Haskell.TH.Ppr++main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |]+

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeData #-}+module TDDataConstructor where++type data P = MkP+data Prom = P+

@@ -0,0 +1,14 @@+{-# LANGUAGE TypeData #-}+{-# LANGUAGE TypeFamilies #-}+module TDExistential where++import Data.Kind (Type)++-- example from GHC User's Guide 6.4.10.6++type data Ex :: Type where+  MkEx :: forall a. a -> Ex++type family UnEx (ex :: Ex) :: k+type instance UnEx (MkEx x) = x+

@@ -0,0 +1,14 @@+{-# LANGUAGE TypeData #-}+module TDGADT where++import Data.Kind (Type)++type data Nat = Zero | Succ Nat++-- type level GADT+type data Vec :: Nat -> Type -> Type where+    VNil :: Vec Zero a+    VCons :: a -> Vec n a -> Vec (Succ n) a++type X = VCons Bool (VCons Int VNil)+

@@ -0,0 +1,11 @@+{-# LANGUAGE TypeData #-}+{-# LANGUAGE GADTs #-}+module TDGoodConsConstraints where++import Data.Kind (Type)+import Data.Type.Equality++type data Foo :: Type -> Type where+  MkFoo1 :: a ~ Int         => Foo a+  MkFoo2 :: a ~~ Int        => Foo a+

@@ -0,0 +1,22 @@+{-# LANGUAGE TypeData #-}+{-# LANGUAGE MonoLocalBinds #-}+module TDVector where++import Data.Kind (Type)++type data Nat = Zero | Succ Nat++type data List a = Nil | Cons a (List a)++type data Pair a b = MkPair a b++type data Sum a b = L a | R b++data Vec :: Nat -> Type -> Type where+    VNil :: Vec Zero a+    VCons :: a -> Vec n a -> Vec (Succ n) a++instance Functor (Vec n) where+    fmap _ VNil = VNil+    fmap f (VCons x xs) = VCons (f x) (fmap f xs)+

@@ -0,0 +1,19 @@+-- Check that splicing in a quoted declaration has the same effect as+-- giving the declaration directly.+{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-}++module TD_TH_splice where++import Data.Kind (Type)++-- splice should be equivalent to giving the declaration directly+$( [d| type data Nat = Zero | Succ Nat |] )++data Vec :: Nat -> Type -> Type where+    VNil :: Vec Zero a+    VCons :: a -> Vec n a -> Vec (Succ n) a++instance Functor (Vec n) where+    fmap _ VNil = VNil+    fmap f (VCons x xs) = VCons (f x) (fmap f xs)+