ghc-exactprint 1.7.1.0 → 1.8.0.0

raw patch · 24 files changed

+1008/−283 lines, 24 filesdep −faildep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependencies removed: fail

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• ChangeLog +2/−0
• ghc-exactprint.cabal +15/−16
• src/Language/Haskell/GHC/ExactPrint/Dump.hs +13/−10
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +220/−138
• src/Language/Haskell/GHC/ExactPrint/Orphans.hs +5/−1
• src/Language/Haskell/GHC/ExactPrint/Parsers.hs +52/−10
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +3/−3
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +1/−10
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +20/−29
• tests/PrepareHackage.hs +3/−2
• tests/Roundtrip.hs +6/−3
• tests/Test.hs +15/−50
• tests/Test/Common.hs +10/−6
• tests/Test/Transform.hs +4/−4
• tests/examples/ghc94/Haddock1.hs +4/−1
• tests/examples/ghc94/Haddock2.hs +8/−0
• tests/examples/ghc98/ExportWarnings_aux.hs +7/−0
• tests/examples/ghc98/IndentedModule2.hs +4/−0
• tests/examples/ghc98/LexerM2.hs +215/−0
• tests/examples/ghc98/ModuleComments.hs +3/−0
• tests/examples/ghc98/MonoidsFD.hs +112/−0
• tests/examples/ghc98/T13343.hs +11/−0
• tests/examples/ghc98/T23465.hs +14/−0
• tests/examples/ghc98/Token.hs +261/−0

@@ -1,3 +1,5 @@+2022-12-19 v1.8.0.0+	* Support GHC 9.8.1 2022-12-19 v1.7.1.0 	* Add CI for GHC 9.6.3 	* Reinstate MonadTrans on TransFormT (via @Vekhir)

@@ -1,11 +1,11 @@ name:                ghc-exactprint-version:             1.7.1.0+version:             1.8.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.6.*. For earlier GHC+                     Note: requires GHC 9.8.*. For earlier GHC                      versions see lower version numbers.                      . @@ -15,9 +15,7 @@ maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:         GHC == 9.6.1,-                     GHC == 9.6.2,-                     GHC == 9.6.3+tested-with:         GHC == 9.8.1 extra-source-files:  ChangeLog                      tests/examples/failing/*.hs                      tests/examples/ghc710-only/*.hs@@ -32,6 +30,7 @@                      tests/examples/ghc92/*.hs                      tests/examples/ghc94/*.hs                      tests/examples/ghc96/*.hs+                     tests/examples/ghc98/*.hs                      tests/examples/pre-ghc810/*.hs                      tests/examples/pre-ghc86/*.hs                      tests/examples/pre-ghc90/*.hs@@ -75,23 +74,22 @@   -- other-extensions:   GHC-Options:         -Wall -Wredundant-constraints   -- GHC-Options:         -Weverything-  build-depends:       base >=4.18 && <4.19+  build-depends:       base >=4.19 && <4.20                      , bytestring >= 0.10.6                      , containers >= 0.5                      , ordered-containers                      , data-default                      , directory >= 1.2                      , filepath  >= 1.4-                     , ghc       >= 9.4.1+                     , ghc       >= 9.8.1                      , mtl       >= 2.2.1                      , syb       >= 0.5                      , free      >= 4.12-                     , fail      >= 4.9 && <4.10                      , ghc-boot     default-language:    Haskell2010-  if impl (ghc < 9.6)+  if impl (ghc < 9.8)       buildable: False  Test-Suite test@@ -110,7 +108,7 @@   GHC-Options:         -threaded -Wall -Wredundant-constraints   Default-language:    Haskell2010   Build-depends:       HUnit >= 1.2-                     , base < 4.19+                     , base < 4.20                      , bytestring                      , containers >= 0.5                      , ordered-containers@@ -119,20 +117,18 @@                      , directory >= 1.2                      , extra                      , filepath  >= 1.4-                     , ghc       >= 9.4.1+                     , ghc       >= 9.8.1                      , ghc-paths  >= 0.1                      , mtl        >= 2.2.1                      , syb        >= 0.5                      , silently   >= 1.2-                     -- for the lib only-                     , fail >= 4.9 && <4.10                      , ghc-boot                      , Cabal-syntax   if flag (dev)       build-depends: free   else       build-depends: ghc-exactprint-  if impl (ghc < 9.4)+  if impl (ghc < 9.8)       buildable: False  executable roundtrip@@ -142,12 +138,13 @@                  Test.CommonUtils                  -- Test.Consistency   default-language:    Haskell2010-  if impl (ghc >= 9.4) && flag (roundtrip)+  if impl (ghc >= 9.8) && flag (roundtrip)     build-depends:                  HUnit                , base                , containers                , directory+               , extra                , filemanip                , filepath                , ghc@@ -169,6 +166,7 @@   if flag (roundtrip)     build-depends: base                  , directory+                 , extra                  , filemanip                  , filepath                  , ghc@@ -187,9 +185,10 @@     build-depends: base                  , containers                  , directory+                 , extra                  , filemanip                  , filepath-                 , ghc       >= 9.4.1+                 , ghc       >= 9.8.1                  , HUnit                  , text   >= 1.2.2                  , turtle >= 1.3.0

@@ -34,7 +34,6 @@ import qualified Data.ByteString as B  import Data.Generics (extQ, ext1Q, ext2Q)-import Language.Haskell.GHC.ExactPrint.Utils  data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan                   deriving (Eq,Show)@@ -63,6 +62,7 @@               `extQ` annotationAnnParen               `extQ` annotationTrailingAnn               `extQ` annotationEpaLocation+              `extQ` annotationNoEpAnns               `extQ` addEpAnn               `extQ` lit `extQ` litr `extQ` litt               `extQ` sourceText@@ -133,12 +133,12 @@             sourceText :: SourceText -> SDoc             sourceText NoSourceText = parens $ text "NoSourceText"             sourceText (SourceText src) = case bs of-              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src-              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src+              NoBlankSrcSpan   -> parens $ text "SourceText" <+> ftext src+              BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src               _                -> 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"@@ -152,7 +152,7 @@              occName n  =  braces $                           text "OccName:"-                      <+> text (occNameString n)+                      <+> ftext (occNameFS n)              moduleName :: ModuleName -> SDoc             moduleName m = braces $ text "ModuleName:" <+> ppr m@@ -161,10 +161,12 @@             srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"              NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (pprSrcSpanWithAnchor ss) 1+                             (hang (ppr ss) 1+                                   -- TODO: show annotations here                                    (text ""))              BlankSrcSpanFile -> braces $ char ' ' <>                              (hang (pprUserSpan False ss) 1+                                   -- TODO: show annotations here                                    (text ""))              realSrcSpan :: RealSrcSpan -> SDoc@@ -172,9 +174,11 @@              BlankSrcSpan -> text "{ ss }"              NoBlankSrcSpan -> braces $ char ' ' <>                              (hang (ppr ss) 1+                                   -- TODO: show annotations here                                    (text ""))              BlankSrcSpanFile -> braces $ char ' ' <>                              (hang (pprUserRealSpan False ss) 1+                                   -- TODO: show annotations here                                    (text ""))  @@ -253,6 +257,9 @@             annotationEpaLocation :: EpAnn EpaLocation -> SDoc             annotationEpaLocation = annotation' (text "EpAnn EpaLocation") +            annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc+            annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")+             annotation' :: forall a .(Data a)                        => SDoc -> EpAnn a -> SDoc             annotation' tag anns = case ba of@@ -296,7 +303,3 @@ normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs normalize_newlines (x:xs)                 = x:normalize_newlines xs normalize_newlines []                     = []--pprSrcSpanWithAnchor :: SrcSpan -> SDoc-pprSrcSpanWithAnchor ss@(UnhelpfulSpan _) = ppr ss-pprSrcSpanWithAnchor ss = ppr ss <+> parens (ppr (hackSrcSpanToAnchor ss))

@@ -51,7 +51,6 @@ import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic-import qualified GHC.Data.Strict as Strict import GHC.Base (NonEmpty(..))  import Language.Haskell.Syntax.Basic (FieldLabelString(..))@@ -133,6 +132,7 @@              , uExtraDP = Nothing              , epComments = []              , epCommentsApplied = []+             , epEof = Nothing              }  @@ -207,6 +207,7 @@              -- Shared              , epComments :: ![Comment]              , epCommentsApplied :: ![[Comment]]+             , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan))              }  -- ---------------------------------------------------------------------@@ -257,11 +258,7 @@ fromAnn' :: (HasEntry a) => a -> Entry fromAnn' an = case fromAnn an of   NoEntryVal -> NoEntryVal-  Entry a c _ u -> Entry a c' FlushComments u-    where-      c' = case c of-        EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs)-        EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct+  Entry a c _ u -> Entry a c FlushComments u  -- --------------------------------------------------------------------- @@ -374,7 +371,7 @@    let mflush = when (flush == FlushComments) $ do         debugM $ "flushing comments in enterAnn:" ++ showAst cs-        flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs))+        flushComments (getFollowingComments cs)    advance edp   a' <- exact a@@ -388,6 +385,17 @@       mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)       debugM $ "ending trailing comments" +  eof <- getEofPos+  case eof of+    Nothing -> return ()+    Just (pos, prior) -> do+       let dp = if pos == prior+             then (DifferentLine 1 0)+             else origDelta pos prior+       debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp)+       printStringAtLsDelta dp ""+       setEofPos Nothing -- Only do this once+   let newAchor = anchor' { anchor_op = MovedAnchor edp }   let r = case canUpdateAnchor of             CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) [])@@ -432,23 +440,12 @@ -- ones in the state. flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () flushComments trailing = do-  addCommentsA (filterEofComment False trailing)+  addCommentsA trailing   cs <- getUnallocatedComments   debugM $ "flushing comments starting"   mapM_ printOneComment (sortComments cs)-  debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)-  debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)-  mapM_ printOneComment (concatMap tokComment (filterEofComment True trailing))   debugM $ "flushing comments done" -filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]-filterEofComment keep cs = fixCs cs-  where-      notEof com = case com of-       L _ (GHC.EpaComment (EpaEofComment) _) -> keep-       _ -> not keep-      fixCs c = filter notEof c- -- ---------------------------------------------------------------------  -- |In order to interleave annotations into the stream, we turn them into@@ -497,7 +494,7 @@  printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () printSourceText (NoSourceText) txt   =  printStringAdvance txt >> return ()-printSourceText (SourceText   txt) _ =  printStringAdvance txt >> return ()+printSourceText (SourceText   txt) _ =  printStringAdvance (unpackFS txt) >> return ()  -- --------------------------------------------------------------------- @@ -518,7 +515,7 @@   p' <- adjustDeltaForOffsetM p   debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p')   printStringAtLsDelta p' str-  setPriorEndASTD True pa+  setPriorEndASTD pa   cs' <- case capture of     CaptureComments -> takeAppliedComments     NoCaptureComments -> return []@@ -573,7 +570,7 @@   p2 <- getPosP   pe2 <- getPriorEndD   debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2)-  setPriorEndASTPD True (pe1,pe2)+  setPriorEndASTPD (pe1,pe2)   cs' <- case capture of     CaptureComments -> takeAppliedComments     NoCaptureComments -> return []@@ -584,7 +581,7 @@  markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m () markExternalSourceText l NoSourceText txt   = printStringAtRs (realSrcSpan l) txt >> return ()-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return ()+markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()  -- --------------------------------------------------------------------- @@ -636,6 +633,15 @@  -- --------------------------------------------------------------------- +markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)+  => Located (HsToken tok) -> EP w m (Located (HsToken tok))+markLToken (L (RealSrcSpan aa mb) t) = do+  epaLoc'<-  printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))+  case epaLoc' of+    EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)+    _               -> return (L (RealSrcSpan aa  mb ) t)+markLToken (L lt t) = return (L lt t)+ markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)   => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) markToken (L NoTokenLoc t) = return (L NoTokenLoc t)@@ -678,21 +684,21 @@  markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) markAnnOpenP an NoSourceText txt   = markEpAnnLMS' an lapr_open AnnOpen (Just txt)-markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt)+markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt)  markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) markAnnOpen an NoSourceText txt   = markEpAnnLMS an lidl AnnOpen (Just txt)-markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt)+markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt)  markAnnOpen' :: (Monad m, Monoid w)   => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt   = printStringAtMLoc' ms txt-markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt+markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt  markAnnOpen'' :: (Monad m, Monoid w)   => EpaLocation -> SourceText -> String -> EP w m EpaLocation markAnnOpen'' el NoSourceText txt   = printStringAtAA el txt-markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt+markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt  -- --------------------------------------------------------------------- {-@@ -1223,24 +1229,6 @@   debugM $ "markAnnListA: an5=" ++ showAst an   return (an5, r) --markAnnList' :: (Monad m, Monoid w)-  => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a)-markAnnList' reallyTrail an action = do-  p <- getPosP-  debugM $ "markAnnList : " ++ showPprUnsafe (p, an)-  an0 <- markLensMAA an lal_open-  an1 <- if (not reallyTrail)-           then markTrailingL an0 lal_trailing-           else return an0-  an2 <- markEpAnnAllL an1 lal_rest AnnSemi-  r <- action-  an3 <- markLensMAA an2 lal_close-  an4 <- if reallyTrail-           then markTrailingL an3 lal_trailing-           else return an3-  return (an4, r)- -- ---------------------------------------------------------------------  printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()@@ -1401,25 +1389,46 @@           m' <- markAnnotated m            mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec+           mexports' <- setLayoutTopLevelP $ markAnnotated mexports+           an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere            return (an1, Just m', mdeprec', mexports') -    let ann_decls = EpAnn (entry an) (am_decls $ anns an0) emptyComments-    (ann_decls', (decls', imports')) <- markAnnList' False ann_decls $ do-      imports' <- markTopLevelList imports-      decls' <- markTopLevelList decls-      return (decls', imports')-    let am_decls' = case ann_decls' of-          EpAnnNotUsed -> (am_decls $ anns an0)-          EpAnn _ r _ -> r+    lo0 <- case lo of+        ExplicitBraces open close -> do+          open' <- markToken open+          return (ExplicitBraces open' close)+        _ -> return lo +    am_decls' <- markTrailing (am_decls $ anns an0)+    imports' <- markTopLevelList imports+    decls' <- markTopLevelList (filter removeDocDecl decls)++    lo1 <- case lo0 of+        ExplicitBraces open close -> do+          close' <- markToken close+          return (ExplicitBraces open close')+        _ -> return lo++    -- Print EOF+    case am_eof $ anns an of+      Nothing -> return ()+      Just (pos, prior) -> do+        debugM $ "am_eof:" ++ showGhc (pos, prior)+        setEofPos (Just (pos, prior))+     let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}-    debugM $ "HsModule, anf=" ++ showAst anf+    -- debugM $ "HsModule, anf=" ++ showAst anf -    return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls')+    return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') ++removeDocDecl :: LHsDecl GhcPs -> Bool+removeDocDecl (L _ DocD{}) = False+removeDocDecl _ = True+ -- ---------------------------------------------------------------------  instance ExactPrint ModuleName where@@ -1436,13 +1445,14 @@   getAnnotationEntry = entryFromLocatedA   setAnnotationAnchor = setAnchorAn -  exact (L (SrcSpanAnn an l) (WarningTxt (L la src) ws)) = do+  exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do     an0 <- markAnnOpenP an src "{-# WARNING"+    mb_cat' <- markAnnotated mb_cat     an1 <- markEpAnnL an0 lapr_rest AnnOpenS     ws' <- markAnnotated ws     an2 <- markEpAnnL an1 lapr_rest AnnCloseS     an3 <- markAnnCloseP an2-    return (L (SrcSpanAnn an3 l) (WarningTxt (L la src) ws'))+    return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' (L la src) ws'))    exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do     an0 <- markAnnOpenP an src "{-# DEPRECATED"@@ -1452,6 +1462,25 @@     an3 <- markAnnCloseP an2     return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws')) +instance ExactPrint InWarningCategory where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ = a++  exact (InWarningCategory tkIn source (L l wc)) = do+      tkIn' <- markLToken tkIn+      L _ (_,wc') <- markAnnotated (L l (source, wc))+      return (InWarningCategory tkIn' source (L l wc'))++instance ExactPrint (SourceText, WarningCategory) where+  getAnnotationEntry _ = NoEntryVal+  setAnnotationAnchor a _ _ = a++  exact (st, WarningCategory wc) = do+      case st of+          NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""+          SourceText src -> printStringAdvance $ (unpackFS src)+      return (st, WarningCategory wc)+ -- ---------------------------------------------------------------------  instance ExactPrint (ImportDecl GhcPs) where@@ -1531,6 +1560,10 @@ instance ExactPrint HsDocString where   getAnnotationEntry _ = NoEntryVal   setAnnotationAnchor a _ _ = a++  -- exact ds = do+  --   (printStringAdvance . exactPrintHsDocString) ds+  --   return ds   exact (MultiLineDocString decorator (x :| xs)) = do     printStringAdvance ("-- " ++ printDecorator decorator)     pe <- getPriorEndD@@ -1790,20 +1823,21 @@   getAnnotationEntry (Warning an _ _) = fromAnn an   setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b -  exact (Warning an lns txt) = do+  exact (Warning an lns  (WarningTxt mb_cat src ls )) = do+    mb_cat' <- markAnnotated mb_cat     lns' <- markAnnotated lns     an0 <- markEpAnnL an lidl AnnOpenS -- "["-    txt' <--      case txt of-        WarningTxt    src ls -> do-          ls' <- markAnnotated ls-          return (WarningTxt    src ls')-        DeprecatedTxt src ls -> do-          ls' <- markAnnotated ls-          return (DeprecatedTxt src ls')+    ls' <- markAnnotated ls     an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"-    return (Warning an1 lns' txt')+    return (Warning an1 lns'  (WarningTxt mb_cat' src ls')) +  exact (Warning an lns (DeprecatedTxt src ls)) = do+    lns' <- markAnnotated lns+    an0 <- markEpAnnL an lidl AnnOpenS -- "["+    ls' <- markAnnotated ls+    an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"+    return (Warning an1 lns' (DeprecatedTxt src ls'))+ -- ---------------------------------------------------------------------  instance ExactPrint StringLiteral where@@ -1834,7 +1868,7 @@     an0 <-       case src of         NoSourceText      -> markEpAnnLMS an lidl AnnOpen  (Just "{-# RULES")-        SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen  (Just srcTxt)+        SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen  (Just $ unpackFS srcTxt)     rules' <- markAnnotated rules     an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}")     return (HsRules (an1,src) rules')@@ -2027,12 +2061,12 @@ -- ---------------------------------------------------------------------  instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty)-     =>  ExactPrint (HsArg tm ty) where+     =>  ExactPrint (HsArg GhcPs tm ty) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a    exact a@(HsValArg tm)    = markAnnotated tm >> return a-  exact a@(HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty >> return a+  exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a   exact x@(HsArgPar _sp)   = withPpr x -- Does not appear in original source  -- ---------------------------------------------------------------------@@ -2121,6 +2155,11 @@     an1 <- markAnnCloseP an0     return (L (SrcSpanAnn an1 l) (Incoherent src)) +  exact (L (SrcSpanAnn an l) (NonCanonical src)) = do+    an0 <- markAnnOpenP an src "{-# INCOHERENT"+    an1 <- markAnnCloseP an0+    return (L (SrcSpanAnn an1 l) (Incoherent src))+ -- ---------------------------------------------------------------------  instance ExactPrint (HsBind GhcPs) where@@ -2751,15 +2790,11 @@         printStringAtAA l  "_" >> return ()         printStringAtAA cb "`" >> return ()         return 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 ()+  exact x@(HsOverLabel _ src l) = do+    printStringAtLsDelta (SameLine 0) "#"+    case src of+      NoSourceText   -> printStringAtLsDelta (SameLine 0) (unpackFS l)+      SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt)     return x    exact x@(HsIPVar _ (HsIPName n))@@ -2771,7 +2806,7 @@                 HsFractional (FL { fl_text = src }) -> src                 HsIsString src _          -> src     case str of-      SourceText s -> printStringAdvance s >> return ()+      SourceText s -> printStringAdvance (unpackFS s) >> return ()       NoSourceText -> withPpr x >> return ()     return x @@ -3184,17 +3219,18 @@     return (HsFieldBind an0 f' arg' isPun)  -- ----------------------------------------------------------------------instance-    (ExactPrint (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body),-     ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body))-    => ExactPrint-         (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)]-                 [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where+instance ExactPrint (LHsRecUpdFields GhcPs) where   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a -  exact (Left rbinds) = Left <$> markAnnotated rbinds-  exact (Right pbinds) = Right <$> markAnnotated pbinds+  exact flds@(RegularRecUpdFields    { recUpdFields  = rbinds }) = do+    debugM $ "RegularRecUpdFields"+    rbinds' <- markAnnotated rbinds+    return $ flds { recUpdFields = rbinds' }+  exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do+    debugM $ "OverloadedRecUpdFields"+    pbinds' <- markAnnotated pbinds+    return $ flds { olRecUpdFields = pbinds' }  -- --------------------------------------------------------------------- @@ -3681,13 +3717,13 @@    an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] -  an00 <- if isTypeDataDefnCons condecls-           then markEpAnnL an' lidl AnnType-           else return an'--  an0 <- markEpAnnL an00 lidl $ case condecls of-    DataTypeCons _ _ -> AnnData-    NewTypeCon   _ -> AnnNewtype+  an0 <- case condecls of+    DataTypeCons is_type_data _ -> do+      an0' <- if is_type_data+                then markEpAnnL an' lidl AnnType+                else return an'+      markEpAnnL an0' lidl AnnData+    NewTypeCon   _ -> markEpAnnL an' lidl AnnNewtype    an1 <- markEpAnnL an0 lidl AnnInstance -- optional   mb_ct' <- mapM markAnnotated mb_ct@@ -3729,12 +3765,13 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do   let     exact_tyvars (varl:varsr)-      | fixity == Infix && length varsr > 1 = do+      | hvarsr : tvarsr@(_ : _) <- varsr+      , fixity == Infix = do           varl' <- markAnnotated varl           thing' <- markAnnotated thing-          hvarsr <- markAnnotated (head varsr)-          tvarsr <- markAnnotated (tail varsr)-          return (thing', varl':hvarsr:tvarsr)+          hvarsr' <- markAnnotated hvarsr+          tvarsr' <- markAnnotated tvarsr+          return (thing', varl':hvarsr':tvarsr')       | fixity == Infix = do           varl' <- markAnnotated varl           thing' <- markAnnotated thing@@ -3788,6 +3825,16 @@         SpecifiedSpec -> (AnnOpenP, AnnCloseP)         InferredSpec  -> (AnnOpenC, AnnCloseC) +instance ExactPrintTVFlag (HsBndrVis GhcPs) where+  exactTVDelimiters an0 bvis thing_inside = do+    case bvis of+      HsBndrRequired -> return ()+      HsBndrInvisible at -> markToken at >> return ()+    an1 <- markEpAnnAllL an0 lid AnnOpenP+    r <- thing_inside+    an2 <- markEpAnnAllL an1 lid AnnCloseP+    return (an2, r)+ instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where   getAnnotationEntry (UserTyVar an _ _)     = fromAnn an   getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an@@ -3819,7 +3866,7 @@   getAnnotationEntry (HsQualTy _ _ _)          = NoEntryVal   getAnnotationEntry (HsTyVar an _ _)          = fromAnn an   getAnnotationEntry (HsAppTy _ _ _)           = NoEntryVal-  getAnnotationEntry (HsAppKindTy _ _ _)       = NoEntryVal+  getAnnotationEntry (HsAppKindTy _ _ _ _)     = NoEntryVal   getAnnotationEntry (HsFunTy an _ _ _)        = fromAnn an   getAnnotationEntry (HsListTy an _)           = fromAnn an   getAnnotationEntry (HsTupleTy an _ _)        = fromAnn an@@ -3843,7 +3890,7 @@   setAnnotationAnchor a@(HsQualTy _ _ _)          _ _s = a   setAnnotationAnchor (HsTyVar an a b)          anc cs = (HsTyVar (setAnchorEpa an anc cs) a b)   setAnnotationAnchor a@(HsAppTy _ _ _)           _ _s = a-  setAnnotationAnchor a@(HsAppKindTy _ _ _)       _ _s = a+  setAnnotationAnchor a@(HsAppKindTy _ _ _ _)     _ _s = a   setAnnotationAnchor (HsFunTy an a b c)        anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c)   setAnnotationAnchor (HsListTy an a)           anc cs = (HsListTy (setAnchorEpa an anc cs) a)   setAnnotationAnchor (HsTupleTy an a b)        anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b)@@ -3884,11 +3931,11 @@     t1' <- markAnnotated t1     t2' <- markAnnotated t2     return (HsAppTy an t1' t2')-  exact (HsAppKindTy ss ty ki) = do+  exact (HsAppKindTy ss ty at ki) = do     ty' <- markAnnotated ty-    printStringAtSs ss "@"+    at' <- markToken at     ki' <- markAnnotated ki-    return (HsAppKindTy ss ty' ki')+    return (HsAppKindTy ss ty' at' ki')   exact (HsFunTy an mult ty1 ty2) = do     ty1' <- markAnnotated ty1     mult' <- markArrow mult@@ -3950,7 +3997,7 @@         NoSourceText -> return an         SourceText src -> do           debugM $ "HsBangTy: src=" ++ showAst src-          an0 <- markEpAnnLMS an lid AnnOpen  (Just src)+          an0 <- markEpAnnLMS an lid AnnOpen  (Just $ unpackFS src)           an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}")           debugM $ "HsBangTy: done unpackedness"           return an1@@ -4137,10 +4184,23 @@           (o',_,c') <- markName a o Nothing c           t' <- markTrailing t           return (NameAnnOnly a o' c' t')-        NameAnnRArrow nl t -> do-          (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)+        NameAnnRArrow unicode o nl c t -> do+          o' <- case o of+            Just o0 -> do+              (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)+              return (Just o')+            Nothing -> return Nothing+          (AddEpAnn _ nl') <-+            if unicode+              then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)+              else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)+          c' <- case c of+            Just c0 -> do+              (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)+              return (Just c')+            Nothing -> return Nothing           t' <- markTrailing t-          return (NameAnnRArrow nl' t')+          return (NameAnnRArrow unicode o' nl' c' t')         NameAnnQuote q name t -> do           debugM $ "NameAnnQuote"           (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)@@ -4500,37 +4560,41 @@  instance ExactPrint (IE GhcPs) where   getAnnotationEntry (IEVar _ _)            = NoEntryVal-  getAnnotationEntry (IEThingAbs an _)      = fromAnn an-  getAnnotationEntry (IEThingAll an _)      = fromAnn an-  getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an-  getAnnotationEntry (IEModuleContents an _)= fromAnn an+  getAnnotationEntry (IEThingAbs (_, an) _)      = fromAnn an+  getAnnotationEntry (IEThingAll (_, an) _)      = fromAnn an+  getAnnotationEntry (IEThingWith (_, an) _ _ _) = fromAnn an+  getAnnotationEntry (IEModuleContents (_, an) _)= fromAnn an   getAnnotationEntry (IEGroup _ _ _)        = NoEntryVal   getAnnotationEntry (IEDoc _ _)            = NoEntryVal   getAnnotationEntry (IEDocNamed _ _)       = NoEntryVal    setAnnotationAnchor a@(IEVar _ _)             _ _s = a-  setAnnotationAnchor (IEThingAbs an a)       anc cs = (IEThingAbs (setAnchorEpa an anc cs) a)-  setAnnotationAnchor (IEThingAll an a)       anc cs = (IEThingAll (setAnchorEpa an anc cs) a)-  setAnnotationAnchor (IEThingWith an a b c)  anc cs = (IEThingWith (setAnchorEpa an anc cs) a b c)-  setAnnotationAnchor (IEModuleContents an a) anc cs = (IEModuleContents (setAnchorEpa an anc cs) a)+  setAnnotationAnchor (IEThingAbs (depr, an) a)       anc cs = (IEThingAbs (depr, setAnchorEpa an anc cs) a)+  setAnnotationAnchor (IEThingAll (depr, an) a)       anc cs = (IEThingAll (depr, setAnchorEpa an anc cs) a)+  setAnnotationAnchor (IEThingWith (depr, an) a b c)  anc cs = (IEThingWith (depr, setAnchorEpa an anc cs) a b c)+  setAnnotationAnchor (IEModuleContents (depr, an) a) anc cs = (IEModuleContents (depr, setAnchorEpa an anc cs) a)   setAnnotationAnchor a@(IEGroup _ _ _)         _ _s = a   setAnnotationAnchor a@(IEDoc _ _)             _ _s = a   setAnnotationAnchor a@(IEDocNamed _ _)        _ _s = a -  exact (IEVar x ln) = do+  exact (IEVar depr ln) = do+    depr' <- markAnnotated depr     ln' <- markAnnotated ln-    return (IEVar x ln')-  exact (IEThingAbs x thing) = do+    return (IEVar depr' ln')+  exact (IEThingAbs (depr, an) thing) = do+    depr' <- markAnnotated depr     thing' <- markAnnotated thing-    return (IEThingAbs x thing')-  exact (IEThingAll an thing) = do+    return (IEThingAbs (depr', an) thing')+  exact (IEThingAll (depr, an) thing) = do+    depr' <- markAnnotated depr     thing' <- markAnnotated thing     an0 <- markEpAnnL an  lidl AnnOpenP     an1 <- markEpAnnL an0 lidl AnnDotdot     an2 <- markEpAnnL an1 lidl AnnCloseP-    return (IEThingAll an2 thing')+    return (IEThingAll (depr', an2) thing') -  exact (IEThingWith an thing wc withs) = do+  exact (IEThingWith (depr, an) thing wc withs) = do+    depr' <- markAnnotated depr     thing' <- markAnnotated thing     an0 <- markEpAnnL an lidl AnnOpenP     (an1, wc', withs') <-@@ -4546,12 +4610,13 @@           as' <- markAnnotated as           return (an2, wc, bs'++as')     an2 <- markEpAnnL an1 lidl AnnCloseP-    return (IEThingWith an2 thing' wc' withs')+    return (IEThingWith (depr', an2) thing' wc' withs') -  exact (IEModuleContents an m) = do+  exact (IEModuleContents (depr, an) m) = do+    depr' <- markAnnotated depr     an0 <- markEpAnnL an lidl AnnModule     m' <- markAnnotated m-    return (IEModuleContents an0 m')+    return (IEModuleContents (depr', an0) m')    -- These three exist to not error out, but are no-ops The contents   -- appear as "normal" comments too, which we process instead.@@ -4728,7 +4793,7 @@                 HsIsString src _ -> src     in       case str of-        SourceText s -> printStringAdvance s >> return ol+        SourceText s -> printStringAdvance (unpackFS s) >> return ol         NoSourceText -> return ol  -- ---------------------------------------------------------------------@@ -4743,7 +4808,13 @@     HsInt        _ (IL src _ v)   -> toSourceTextWithSuffix src v ""     HsIntPrim    src v   -> toSourceTextWithSuffix src v ""     HsWordPrim   src v   -> toSourceTextWithSuffix src v ""+    HsInt8Prim   src v   -> toSourceTextWithSuffix src v ""+    HsInt16Prim  src v   -> toSourceTextWithSuffix src v ""+    HsInt32Prim  src v   -> toSourceTextWithSuffix src v ""     HsInt64Prim  src v   -> toSourceTextWithSuffix src v ""+    HsWord8Prim  src v   -> toSourceTextWithSuffix src v ""+    HsWord16Prim src v   -> toSourceTextWithSuffix src v ""+    HsWord32Prim src v   -> toSourceTextWithSuffix src v ""     HsWord64Prim src v   -> toSourceTextWithSuffix src v ""     HsInteger    src v _ -> toSourceTextWithSuffix src v ""     HsRat        _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl ""@@ -4752,11 +4823,11 @@  toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText)    alt suffix = show alt ++ suffix-toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix+toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix  sourceTextToString :: SourceText -> String -> String sourceTextToString NoSourceText alt   = alt-sourceTextToString (SourceText txt) _ = txt+sourceTextToString (SourceText txt) _ = unpackFS txt  -- --------------------------------------------------------------------- @@ -4816,11 +4887,14 @@   colOffset <- getLayoutOffsetP   if isGoodDeltaWithOffset cl colOffset     then do+      dprior <- getPriorEndD       printStringAt (undelta p cl colOffset) s-        -- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s))+        -- `debug` ("printStringAtLsDelta:(cl,colOffset):" ++ show (cl,colOffset,s))       p' <- getPosP-      d <- getPriorEndD-      debugM $ "printStringAtLsDelta:(pos,p',d,s):" ++ show (undelta p cl colOffset,p',d,s)+      dafter <- getPriorEndD+      setPriorEndASTPD (dprior,dafter)++      debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',dafter,s)     else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s))  -- ---------------------------------------------------------------------@@ -4881,7 +4955,7 @@  setPosP :: (Monad m, Monoid w) => Pos -> EP w m () setPosP l = do-  -- debugM $ "setPosP:" ++ show l+  debugM $ "setPosP:" ++ show l   modify (\s -> s {epPos = l})  getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor)@@ -4907,13 +4981,13 @@   debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe   modify (\s -> s { dPriorEndPosition = pe }) -setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m ()-setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe)+setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m ()+setPriorEndASTD pe = setPriorEndASTPD (rs2range pe) -setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m ()-setPriorEndASTPD layout pe@(fm,to) = do+setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m ()+setPriorEndASTPD pe@(fm,to) = do   debugM $ "setPriorEndASTD:pe=" ++ show pe-  when layout $ setLayoutStartD (snd fm)+  when True $ setLayoutStartD (snd fm)   modify (\s -> s { dPriorEndPosition = to } )  setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m ()@@ -4931,6 +5005,14 @@ setAnchorU rss = do   debugM $ "setAnchorU:" ++ show (rs2range rss)   modify (\s -> s { uAnchorSpan = rss })++getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan))+getEofPos = gets epEof++setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m ()+setEofPos l = modify (\s -> s {epEof = l})++-- ---------------------------------------------------------------------  getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] getUnallocatedComments = gets epComments

@@ -4,6 +4,7 @@  import Data.Default import GHC hiding (EpaComment)+import GHC.Types.SrcLoc  -- --------------------------------------------------------------------- @@ -89,5 +90,8 @@ instance Default EpAnnSumPat where   def = EpAnnSumPat def  def  def +instance Semigroup RealSrcSpan where+    a <> b = combineRealSrcSpans a b+ instance Default AnnsModule where-  def = AnnsModule [] mempty+  def = AnnsModule [] mempty mempty

@@ -47,7 +47,6 @@  import Language.Haskell.GHC.ExactPrint.Preprocess --- import Control.Monad.RWS import Data.Functor (void)  import qualified GHC hiding (parseModule)@@ -261,7 +260,7 @@       GHC.PFailed pst         -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst)       GHC.POk _ pmod-        -> Right $ (injectedComments, dflags', fixModuleTrailingComments pmod)+        -> Right $ (injectedComments, dflags', fixModuleComments pmod)  -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing.@@ -270,23 +269,24 @@   -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes   where-    -- TODO:AZ perhaps inject the comments into the parsedsource here already-    mkAnns (_cs, _, m) = fixModuleTrailingComments m+    mkAnns (_cs, _, m) = fixModuleComments m +fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource+fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p+ fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleTrailingComments (GHC.L l p) = GHC.L l p'   where     an' = case GHC.hsmodAnn $ GHC.hsmodExt p of-      (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs)+      (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance ocs)       unused -> unused     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'+    rebalance :: GHC.EpAnnComments -> GHC.EpAnnComments+    rebalance cs = cs'       where-        cs' = case GHC.al_close al of-          Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) ->+        cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of+          GHC.ExplicitBraces _  (GHC.L (GHC.TokenLoc (GHC.EpaSpan ss _)) _) ->             let               pc = GHC.priorComments cs               fc = GHC.getFollowingComments cs@@ -295,6 +295,48 @@               cs'' = GHC.EpaCommentsBalanced (pc <> prior) f             in cs''           _ -> cs++-- Deal with https://gitlab.haskell.org/ghc/ghc/-/issues/23984+-- The Lexer works bottom-up, so does not have module declaration info+-- when the first top decl processed+fixModuleHeaderComments :: GHC.ParsedSource -> GHC.ParsedSource+fixModuleHeaderComments (GHC.L l p) = GHC.L l p'+  where+    moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments+                 -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments)+    moveComments GHC.EpaDelta{} dd cs = (dd,cs)+    moveComments _loc dd@(GHC.L (GHC.SrcSpanAnn GHC.EpAnnNotUsed _) _) cs = (dd,cs)+    moveComments (GHC.EpaSpan r _) (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd) ll) a) cs = (dd,css)+      where+        -- Move any comments on the decl that occur prior to the location+        pc = GHC.priorComments csd+        fc = GHC.getFollowingComments csd+        bf (GHC.L anch _) = GHC.anchor anch > r+        (move,keep) = break bf pc+        csd' = GHC.EpaCommentsBalanced keep fc++        dd = GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd') ll) a+        css = cs <> GHC.EpaComments move++    (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p)+    p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' },+             GHC.hsmodDecls = ds'+           }++    rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)+              -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule)+    rebalance (ds, GHC.EpAnnNotUsed) = (ds, GHC.EpAnnNotUsed)+    rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs')+      where+        (ds1,cs') = case break (\(GHC.AddEpAnn k _) -> k == GHC.AnnWhere) (GHC.am_main an) of+                     (_, (GHC.AddEpAnn _ whereLoc:_)) ->+                           case GHC.hsmodDecls p of+                               (d:ds0) -> (d':ds0, cs0)+                                   where (d',cs0) = moveComments whereLoc d cs+                               ds0 -> (ds0,cs)+                     _ -> (ds,cs)++  -- | Internal function. Initializes DynFlags value for parsing. --

@@ -26,7 +26,6 @@ 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@@ -195,7 +194,7 @@ stripPreprocessorDirectives buf = buf'   where     srcByLine = lines $ sbufToString buf-    noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine+    noDirectivesLines = map (\line -> case line of '#' : _ -> ""; _ -> line) srcByLine     buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines  -- ---------------------------------------------------------------------@@ -227,6 +226,7 @@       txt <- GHC.liftIO $ readFileGhc hspp_fn       return (txt, buf, dflags') +-- showErrorMessages :: GHC.Messages GHC.DriverMessage -> String showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String showErrorMessages msgs =   GHC.renderWithContext GHC.defaultSDocContext@@ -262,7 +262,7 @@ getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)] getPreprocessorAsComments srcFile = do   fcontents <- readFileGhc srcFile-  let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')+  let directives = filter (\(_lineNum,line) -> case line of '#' : _ -> True; _ -> False)                     $ zip [1..] (lines fcontents)    let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line)

@@ -325,7 +325,7 @@                l) a               where                 cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs')-                lc = head $ reverse $ (L ca c:cs')+                lc = last $ (L ca c:cs')                 delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r                 line = getDeltaLine delta                 col = deltaColumn delta@@ -709,15 +709,6 @@         op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0)                then MovedAnchor (DifferentLine 1 0)                else op'---- -------------------------------------------------------------------------- | For comment-related deltas starting on a new line we have an--- off-by-one problem. Adjust-tweakDelta :: DeltaPos  -> DeltaPos-tweakDelta (SameLine d) = SameLine d-tweakDelta (DifferentLine l d) = DifferentLine l (d-1)  -- --------------------------------------------------------------------- 

@@ -4,20 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.GHC.ExactPrint.Utils-  -- (-  --  -- * Manipulating Positons-  --   ss2pos-  -- , ss2posEnd-  -- , undelta-  -- , isPointSrcSpan-  -- , pos2delta-  -- , ss2delta-  -- , addDP-  -- , spanLength-  -- , isGoodDelta-  -- ) where-  where+module Language.Haskell.GHC.ExactPrint.Utils where  import Control.Monad (when) import Data.Function@@ -171,6 +158,25 @@  -- --------------------------------------------------------------------- +origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos+origDelta pos pp = op+  where+    (r,c) = ss2posEnd pp++    op = if r == 0+           then (             ss2delta (r,c+1) pos)+           else (tweakDelta $ ss2delta (r,c  ) pos)++-- ---------------------------------------------------------------------++-- | For comment-related deltas starting on a new line we have an+-- off-by-one problem. Adjust+tweakDelta :: DeltaPos  -> DeltaPos+tweakDelta (SameLine d) = SameLine d+tweakDelta (DifferentLine l d) = DifferentLine l (d-1)++-- ---------------------------------------------------------------------+ -- |Given a list of items and a list of keys, returns a list of items -- ordered by their position in the list of keys. orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]@@ -349,21 +355,6 @@  name2String :: Name -> String name2String = showPprUnsafe---- ------------------------------------------------------------------------- occAttributes :: OccName.OccName -> String--- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"---   where---     -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "---     ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "---     vo = if isVarOcc     o then "Var "     else ""---     tv = if isTvOcc      o then "Tv "      else ""---     tc = if isTcOcc      o then "Tc "      else ""---     d  = if isDataOcc    o then "Data "    else ""---     ds = if isDataSymOcc o then "DataSym " else ""---     s  = if isSymOcc     o then "Sym "     else ""---     v  = if isValOcc     o then "Val "     else ""   -- --------------------------------------------------------------------- 

@@ -43,10 +43,11 @@ preparePackage' :: Text -> IO () preparePackage' package = do   (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty-  -- myecho (T.pack $ "cabal get:" ++ show dir)+  myecho (T.pack $ "cabal get:" ++ show dir)+  -- cabal get:"Unpacking to\n./hackage-roundtrip-work/amazonka-kinesis-video-archived-media-2.0/\n"   myecho (T.pack $ show ec)   when (ec == ExitSuccess) $ do-    let bits = T.splitOn " " (head $ T.lines dir)+    let bits = T.splitOn " " (last $ T.lines dir)     myecho (T.pack $ "cabal get:dir=" ++ show (last bits))     cleanPackage (last bits)   return ()

@@ -82,6 +82,8 @@   case as of     [] -> putStrLn "Must enter directory to process"     ["failures"] -> do+      -- !knownFailures <- readFileIfPresent knownFailuresFile+      -- let done = S.fromList knownFailures       fs <- lines <$> readFile origFailuresFile       () <$ runTests (TestList (map (mkParserTest libdir) fs))     ["clean"] -> do@@ -122,10 +124,11 @@ -- Hackage dir roundTripHackage :: LibDir -> S.Set String -> FilePath -> IO Test roundTripHackage libdir done hackageDir = do-  packageDirs <- drop 2 <$> getDirectoryContents hackageDir+  packageDirs <- listDirectory hackageDir+  dirsOnly <- filterM (doesDirectoryExist . (hackageDir </>)) packageDirs   when (verb <= Debug) (traceShowM hackageDir)-  when (verb <= Debug) (traceShowM packageDirs)-  TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir </>) packageDirs))+  when (verb <= Debug) (traceShowM dirsOnly)+  TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir </>) dirsOnly))   roundTripPackage :: LibDir -> S.Set String -> (Int, FilePath) -> IO Test

@@ -28,25 +28,25 @@  -- --------------------------------------------------------------------- -data GHCVersion = GHC94-           | GHC96+data GHCVersion = GHC96+           | GHC98      deriving (Eq, Ord, Show)  ghcVersion :: GHCVersion-#if MIN_VERSION_ghc(9,6,0)-ghcVersion = GHC96+#if MIN_VERSION_ghc(9,8,0)+ghcVersion = GHC98 #else-ghcVersion = GHC94+ghcVersion = GHC96 #endif  -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs =   case ghcVersion of-    GHC94  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94"]     GHC96  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96"]-    -- GHC96  -> ["ghc96"]-    -- GHC96  -> ["ghc96-copied"]+    GHC98  -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96", "ghc98"]+    -- GHC98  -> ["ghc98"]+    -- GHC98  -> ["ghc98-copied"]  -- --------------------------------------------------------------------- @@ -183,9 +183,9 @@  formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () formatTT (ts, fs) = do-  when (not . null $ tail ts) (do+  when (not . null $ (drop 1) ts) (do     putStrLn "Pass"-    mapM_ (putStrLn . fst) (tail ts)+    mapM_ (putStrLn . fst) ((drop 1) ts)     )   when (not . null $ fs) (do     putStrLn "Fail"@@ -201,49 +201,10 @@ tt' = do   let libdir = GHC.Paths.libdir   runTestText (putTextToHandle stdout True) $ TestList [--    -- mkTestModChange libdir rmDecl7 "RmDecl7.hs"--    -- mkTestModChange libdir changeLocalDecls  "LocalDecls.hs"-    -- mkTestModChange libdir changeLayoutLet2 "LayoutLet2.hs"-    -- mkTestModChange libdir addLocaLDecl5  "AddLocalDecl5.hs"--   -- mkTestModChange libdir rmDecl1 "RmDecl1.hs"--   -- mkTestModChange libdir rmDecl4 "RmDecl4.hs"-    -- mkParserTestMD libdir      "ghc92" "Foo.hs"-    -- mkParserTest libdir      "ghc92" "Foo.hs"-    -- mkParserTestMD libdir      "ghc92" "Foo.hs"-    -- mkParserTest libdir      "ghc92" "Foo2.hs"-    -- mkParserTest libdir      "ghc710" "EmptyMostly.hs"-    -- mkParserTestBC libdir "ghc710" "Control.hs"-    -- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs"-    -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"--    -- mkParserTest libdir      "ghc92" "ConstructorComment.hs"-    -- mkParserTest libdir      "ghc92" "Binary.hs"-    -- mkParserTest libdir      "ghc92" "Observer.hs"-    -- mkParserTest libdir      "ghc92" "Observer1.hs"--   -- mkTestModChange libdir addLocaLDecl1  "AddLocalDecl1.hs"-   -- mkTestModChange libdir addLocaLDecl3  "AddLocalDecl3.hs"--    -- mkParserTestBC libdir "ghc710" "MultiParamTypeClasses.hs"--    -- mkParserTestBC libdir "ghc710" "DataFamilies.hs"-    -- mkParserTestBC libdir "ghc710" "Cpp.hs"-    -- mkParserTestBC libdir "ghc80" "T4139.hs"--    -- mkParserTestBC libdir "ghc92" "Checkpoint.hs"--    -- mkParserTestBC libdir "ghc92" "CommentPlacement6.hs"-    -- mkParserTest libdir "ghc92" "CommentPlacement6.hs"-     -- mkParserTest libdir "ghc92" "TopLevelSemis.hs"     -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"     -- mkParserTestMD libdir "ghc92" "TopLevelSemis.hs" -     -- mkParserTest libdir "ghc96" "T11671_run.hs"      -- mkParserTest libdir "ghc96" "LexerM.hs"@@ -251,7 +212,11 @@      -- mkParserTest libdir "ghc94" "Haddock.hs"     -- mkParserTest libdir "ghc94" "Haddock1.hs"-    mkParserTestBC libdir "ghc94" "Haddock1.hs"+    -- mkParserTest libdir "ghc94" "Haddock2.hs"+    -- mkParserTestBC libdir "ghc94" "Haddock1.hs"++    -- mkParserTest libdir "ghc98" "IndentedModule2.hs"+    mkParserTest libdir "ghc98" "ModuleComments.hs"     -- Needs GHC changes 

@@ -31,16 +31,13 @@   import Language.Haskell.GHC.ExactPrint--- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess  import qualified Control.Monad.IO.Class as GHC-import qualified GHC           as GHC hiding (parseModule)--- import qualified GHC.Data.Bag          as GHC+import qualified GHC hiding (parseModule) import qualified GHC.Driver.Session    as GHC--- import qualified GHC.Utils.Error       as GHC  import qualified GHC.LanguageExtensions as LangExt @@ -146,6 +143,13 @@               cppStatus = if useCpp then Just orig else Nothing           return $ Right Report {..} +-- showErrorMessages :: Messages GhcMessage -> String+-- showErrorMessages msgs =+--   renderWithContext defaultSDocContext+--     $ vcat+--     $ pprMsgEnvelopeBagWithLocDefault+--     $ getMessages+--     $ msgs  mkDebugOutput :: FilePath -> String -> String               -> GHC.ParsedSource -> String@@ -199,7 +203,7 @@    let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph   case mm of-   [] -> return Nothing-   fs -> return (Just (snd $ head fs))+   (f:_) -> return (Just (snd f))+   _ -> return Nothing  -- ---------------------------------------------------------------------

@@ -618,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 noExtField n1)))-          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))           impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0)                                      (AnnList Nothing                                               (Just (AddEpAnn AnnOpenP  d1))@@ -653,8 +653,8 @@                                        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 noExtField n1)))-          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))+          v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1)))+          v2 = L (           noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2)))           L ln n = last ns           n' = L (addComma ln) n           imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))}

@@ -30,4 +30,7 @@ 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) -- ^+   B (T a b, T Int Float) -- ^ abcd++-- | An abstract data declaration+data T2 a b = T2 a b

@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock -ddump-parsed -dkeep-comments #-}+module Haddock2 where++data T+ = B -- ^ abcd++-- | An abstract data declaration+data T2 = T2

@@ -0,0 +1,7 @@+module ExportWarnings_aux (+    {-# WARNING "warn" #-} x,+    {-# WARNING  in    "x-custom-\72"  [ "is"  ,  "deprecated"] #-} S(S1),+  ) where+import ExportWarnings_base (x)++data S = S1 | S2

@@ -0,0 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-}+{- -} module Main where+main = putStr "foo"+

@@ -0,0 +1,215 @@+----------------------------------------------------------------------------+-- |+-- Module      :  FastTags.LexerM+-- Copyright   :  (c) Sergey Vinokurov 2019+--+-- All the types and functions needed to make lexer run:+-- - 'AlexInput' - primary workhorse, an optimized representation of input+--   stream as a pointer to utf8 bytes and our position within it.+-- - Lexer monad 'AlexM' - a monad (self-explanatory) with state that describes+--   current lexing context.+-- - 'AlexState' - state of the lexing monad, maintains current Alex code,+--   comment depth, quasiquoter depth, indentation size, whether we're in+--   a literate mode (and in which one) or vanilla mode and whether there+--   are any TH quasiquotes present till the end of file.+--+-- All the functions are to do with+----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiWayIf                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UnboxedTuples              #-}++module FastTags.LexerM+    ( AlexState(..)+    , mkAlexState+    , alexEnterBirdLiterateEnv+    , alexEnterLiterateLatexEnv+    , alexExitLiterateEnv+    , pushContext+    , modifyCommentDepth+    , modifyQuasiquoterDepth+    , modifyPreprocessorDepth+    , addIndentationSize+    , checkQuasiQuoteEndPresent++    , AlexM+    , runAlexM+    , alexSetInput+    , alexSetNextCode++    , AlexInput(..)+    , aiLineL+    , takeText+    , countInputSpace+    , extractDefineOrLetName+    , dropUntilNL+    , dropUntilUnescapedNL+    , dropUntilNLOr+    , dropUntilNLOrEither+    , unsafeTextHeadAscii+    , unsafeTextHeadOfTailAscii+    , unsafeTextHead+    , utf8BS++    , asCodeL+    , asCommentDepthL+    , asQuasiquoterDepthL+    , asIndentationSizeL+    , asPreprocessorDepthL+    , asLiterateLocL+    , asHaveQQEndL++      -- * Alex interface+    , alexInputPrevChar+    , alexGetByte+    ) where++import Control.Applicative as A+import Control.DeepSeq+import Control.Exception+import Control.Monad.ST+import Control.Monad.State.Strict+import Control.Monad.Writer.Strict++import Data.Char+import Data.Int+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Void (Void, vacuous)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Internal as BSI+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as UM++import Foreign.ForeignPtr+import Foreign.Ptr+import GHC.Base+import GHC.Ptr+import GHC.Word+import Text.Printf++import FastTags.LensBlaze+import FastTags.LexerTypes+import FastTags.Token++import GHC.Exts (word8ToWord#, wordToWord8#)+++data AlexState = AlexState+    { asInput        :: {-# UNPACK #-} !AlexInput+    , asIntStore     :: {-# UNPACK #-} !Word64+        -- ^ Integer field that stores all the other useful fields for lexing.+    , asContextStack :: [Context]+    } deriving (Show, Eq, Ord)+++checkQuasiQuoteEndPresent :: Ptr Word8 -> Bool+checkQuasiQuoteEndPresent+    = (\x -> isTrue# (qqessPresent x))+    . utf8Foldl' combine (QQEndsState 0# '\n'#)+    where+    combine :: QQEndsState -> Char# -> QQEndsState+    combine QQEndsState{qqessPresent, qqessPrevChar} c# = QQEndsState+        { qqessPresent      =+          qqessPresent `orI#`+          case (# qqessPrevChar, c# #) of+              (# '|'#, ']'# #) -> 1#+              (# _,    '⟧'# #) -> 1#+              _                -> 0#+        , qqessPrevChar = c#+        }++countInputSpace :: AlexInput -> Int -> Int+countInputSpace AlexInput{aiPtr} len =+    utf8FoldlBounded len inc 0 aiPtr+    where+    inc !acc ' '#  = acc + 1+    inc !acc '\t'# = acc + 8+    inc !acc c#    = case fixChar c# of+        1## -> acc + 1+        _   -> acc++-- Translate unicode character into special symbol we teached Alex to recognize.+{-# INLINE fixChar #-}+fixChar :: Char# -> Word#+fixChar = \case+    -- These should not be translated since Alex knows about them+    '→'#    -> reservedSym+    '∷'#    -> reservedSym+    '⇒'#    -> reservedSym+    '∀'#    -> reservedSym+    '⦇'#    -> reservedSym+    '⦈'#    -> reservedSym+    '⟦'#    -> reservedSym+    '⟧'#    -> reservedSym+    '\x00'# -> fullStop+    '\x01'# -> fullStop+    '\x02'# -> fullStop+    '\x03'# -> fullStop+    '\x04'# -> fullStop+    '\x05'# -> fullStop+    '\x06'# -> fullStop+    '\x07'# -> fullStop+    '\x08'# -> other+    c# -> case ord# c# of+        c2# | isTrue# (c2# <=# 0x7f#) ->+              int2Word# c2# -- Plain ascii needs no fixing.+            | otherwise   ->+                case generalCategory (C# c#) of+                    UppercaseLetter      -> upper+                    LowercaseLetter      -> lower+                    TitlecaseLetter      -> upper+                    ModifierLetter       -> suffix+                    OtherLetter          -> lower+                    NonSpacingMark       -> suffix+                    DecimalNumber        -> digit+                    OtherNumber          -> digit+                    Space                -> space+                    ConnectorPunctuation -> symbol+                    DashPunctuation      -> symbol+                    OtherPunctuation     -> symbol+                    MathSymbol           -> symbol+                    CurrencySymbol       -> symbol+                    ModifierSymbol       -> symbol+                    OtherSymbol          -> symbol++                    SpacingCombiningMark -> space+                    EnclosingMark        -> other+                    LetterNumber         -> symbol+                    OpenPunctuation      -> symbol+                    ClosePunctuation     -> symbol+                    InitialQuote         -> symbol+                    FinalQuote           -> symbol+                    LineSeparator        -> space+                    ParagraphSeparator   -> space+                    Control              -> other+                    Format               -> other+                    Surrogate            -> other+                    PrivateUse           -> other+                    NotAssigned          -> other+    where+      fullStop, space, upper, lower, symbol :: Word#+      digit, suffix, reservedSym, other :: Word#+      fullStop    = 0x00## -- Don't care about these+      space       = 0x01##+      upper       = 0x02##+      lower       = 0x03##+      symbol      = 0x04##+      digit       = 0x05##+      suffix      = 0x06##+      reservedSym = 0x07##+      other       = 0x08##+

@@ -0,0 +1,3 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+x = 1

@@ -0,0 +1,112 @@+-- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html++-------------------- FUNCTIONAL DEPENDENCY VERSION ----------------++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE UnicodeSyntax #-}++module Main where+import Control.Monad (Monad(..), join, ap)+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))++-- First we define the type class Monoidy:++class Monoidy to comp id m | m to → comp id where+  munit :: id `to` m+  mjoin :: (m `comp` m) `to` m++-- We use functional dependencies to help the typechecker understand that+-- m and ~> uniquely determine comp (times) and id.+--+-- This kind of type class would not have been possible in previous+-- versions of GHC; with the new kind system, however, we can abstract+-- over kinds!2 Now, let’s create types for the additive and+-- multiplicative monoids over the natural numbers:++newtype Sum a = Sum a deriving Show+newtype Product a = Product a deriving Show+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where+  munit _ = Sum 0+  mjoin (Sum x, Sum y) = Sum $ x + y+instance Num a ⇒ Monoidy (→) (,) () (Product a) where+  munit _ = Product 1+  mjoin (Product x, Product y) = Product $ x * y++-- It will be slightly more complicated to make a monadic instance with+-- Monoidy. First, we need to define the identity functor, a type for+-- natural transformations, and a type for functor composition:++data Id α = Id { runId :: α } deriving Functor++-- A natural transformation (Λ f g α. (f α) → (g α)) may be encoded in Haskell as follows:++data NT f g = NT { runNT :: ∀ α. f α → g α }++-- Functor composition (Λ f g α. f (g α)) is encoded as follows:++data FC f g α = FC { runFC :: f (g α) }++-- Now, let us define some type T which should be a monad:++data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor)+instance Monoidy NT FC Id Wrapper where+  munit = NT $ Wrapper . runId+  mjoin = NT $ runWrapper . runFC++-- With these defined, we can use them as follows:++test1 = do { print (mjoin (munit (), Sum 2))+                 -- Sum 2+           ; print (mjoin (Product 2, Product 3))+                 -- Product 6+           ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world"))+                 -- Wrapper {runWrapper = "hello, world" }+           }++-- We can even provide a special binary operator for the appropriate monoids as follows:++(<+>) :: Monoidy (→) (,) () m ⇒ m → m → m+(<+>) = curry mjoin++test2 = print (Sum 1 <+> Sum 2 <+> Sum 4)  -- Sum 7++-- Now, all the extra wrapping that Haskell requires for encoding this is+-- rather cumbersome in actual use. So, we can give traditional Monad and+-- Monoid instances for instances of Monoidy:++instance Monoidy (→) (,) () m ⇒ Semigroup m where+  (<>) = curry mjoin++instance Monoidy (→) (,) () m ⇒ Monoid m where+  mempty = munit ()++instance Applicative Wrapper where+  pure x = runNT munit $ Id x+  (<*>) = ap++-- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where+instance Monad Wrapper where+   x >>= f = runNT mjoin $ FC (f `fmap` x)++-- And so the following works:++test3+ = do { print (mappend mempty (Sum 2))+             -- Sum 2+      ; print (mappend (Product 2) (Product 3))+             -- Product 6+      ; print (join $ Wrapper $ Wrapper "hello")+             -- Wrapper {runWrapper = "hello" }+      ; print (Wrapper "hello, world" >>= return)+             -- Wrapper {runWrapper = "hello, world" }+      }++main = test1 >> test2 >> test3

@@ -0,0 +1,11 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+module Bug where++import GHC.Exts++type Bad :: forall v . TYPE v+type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v++-- Note v /= v1.+

@@ -0,0 +1,14 @@+module T23465 {-# WaRNING in "x-a" "b" #-} where++{-# WARNInG in "x-c" e "d" #-}+e = e++{-# WARNInG+   in "x-f" f "fw" ;+   in "x-f" g "gw"+#-}+f = f+g = g++{-# WARNinG h "hw" #-}+h = h

@@ -0,0 +1,261 @@+{-# language BangPatterns #-}+{-# language BinaryLiterals #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language PolyKinds #-}+{-# language RankNTypes #-}+{-# language StandaloneDeriving #-}+{-# language TypeApplications #-}+{-# language UnboxedTuples #-}++module Json.Token+  ( Token(..)+  , TokenException(..)+  , decode+  ) where++import Control.Monad.ST (ST,runST)+import Data.Bits ((.&.),(.|.),unsafeShiftR)+import Data.Builder.ST (Builder)+import Data.Bytes.Parser (Parser)+import Data.Bytes.Types (Bytes(..))+import Data.Char (ord)+import Data.Primitive (MutableByteArray,ByteArray)+import Data.Primitive (SmallArray)+import Data.Text.Short (ShortText)+import Data.Word (Word8,Word16)+import GHC.Exts (Int(I#),Char(C#))+import GHC.Exts (word2Int#,chr#,gtWord#,ltWord#)+import GHC.Word (Word16(W16#),Word8(W8#))+import Data.Number.Scientific (Scientific)++import qualified Data.ByteString.Short.Internal as BSS+import qualified Data.Bytes.Parser as P+import qualified Data.Bytes.Parser.Utf8 as Utf8+import qualified Data.Bytes.Parser.Latin as Latin+import qualified Data.Bytes.Parser.Unsafe as Unsafe+import qualified Data.Builder.ST as B+import qualified Data.Chunks as C+import qualified Data.Primitive as PM+import qualified Data.Text.Short.Unsafe as TS+import qualified Data.Number.Scientific as SCI++-- | A token in a JSON document.+data Token+  = LeftBrace+  | RightBrace+  | LeftBracket+  | RightBracket+  | Comma+  | Colon+  | BooleanTrue+  | BooleanFalse+  | Null+  | String {-# UNPACK #-} !ShortText+  | Number {-# UNPACK #-} !Scientific+  deriving stock (Eq,Show)++-- | An exception encountered while tokenizing a JSON document.+data TokenException+  = InvalidNumber+  | InvalidLeader+  | ExpectedTrue+  | ExpectedFalse+  | ExpectedNull+  | LeadingZero+  | InvalidEscapeSequence+  | IncompleteString+  | IncompleteEscapeSequence+  deriving stock (Eq,Show)++isSpace :: Word8 -> Bool+isSpace w =+     w == c2w ' '+  || w == c2w '\t'+  || w == c2w '\r'+  || w == c2w '\n'++-- | Decode a sequence as JSON tokens. This allows token+-- sequences that would be rejected by the ABNF given in+-- <https://tools.ietf.org/html/rfc7159 RFC 7159>:+--+-- >>> decode (Bytes.fromAsciiString "[ , true }")+-- Right [ LeftBracket, Comma, BooleanTrue, RightBrace ]+--+-- It is up to the user to reject such malformed JSON when+-- they parse the token sequence. More surprisingly, this+-- tokenizer accepts some unnatural juxtapositions of token+-- sequences without whitespace. For example:+--+-- >>> decode (Bytes.fromAsciiString "55truefalse")+-- Right [ Number 55, BooleanTrue, BooleanFalse ]+-- >>> decode (Bytes.fromAsciiString "null\"hello\"")+-- Right [ Null, String "hello" ]+--+-- Acceptance of such samples simplifies the implementation+-- of this tokenizer. These unnatural juxtapositions always+-- result in token sequences that should be rejected anyway in+-- the subsequent parsing done by the user. Consequently, their+-- acceptance is not considered harmful.+decode :: Bytes -> Either TokenException (SmallArray Token)+decode !bs = runST $ do+  !b <- B.new+  P.parseBytesEffectfully (P.skipWhile isSpace *> manyTokens b) bs >>= \case+    P.Failure err -> pure (Left err)+    -- Since manyTokens only completes once the end of the input+    -- has been reached, we do not need to check the length here.+    P.Success (P.Slice _ _ cs) -> pure (Right cs)++manyTokens ::+     Builder s Token+  -> Parser TokenException s (SmallArray Token)+manyTokens !b0 = do+  t <- oneToken+  !b1 <- P.effect (B.push t b0)+  P.skipWhile isSpace+  done <- P.isEndOfInput+  if done+    then P.effect $ do+      cs <- B.freeze b1+      pure $! C.concat cs+    else manyTokens b1++-- TODO: oneToken is only called in contexts where the initial+-- call to Latin.any cannot fail. Consider refactoring to make+-- this more explicit.+oneToken :: Parser TokenException s Token+oneToken = Latin.any InvalidLeader >>= \case+  '{' -> pure LeftBrace+  '}' -> pure RightBrace+  '[' -> pure LeftBracket+  ']' -> pure RightBracket+  ',' -> pure Comma+  ':' -> pure Colon+  't' -> do+    Latin.char3 ExpectedTrue 'r' 'u' 'e'+    pure BooleanTrue+  'f' -> do+    Latin.char4 ExpectedFalse 'a' 'l' 's' 'e'+    pure BooleanFalse+  'n' -> do+    Latin.char3 ExpectedNull 'u' 'l' 'l'+    pure Null+  '"' -> do+    start <- Unsafe.cursor+    string start+  '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber)+  '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case+    True -> P.fail LeadingZero+    False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0)+  c | c >= '1' && c <= '9' ->+        fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber (ord c - 48))+  _ -> P.fail InvalidLeader++copyAndEscape :: Int -> Parser TokenException s Token+copyAndEscape !maxLen = do+  !dst <- P.effect (PM.newByteArray maxLen)+  let go !ix = Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of+        '\\'# -> Latin.any IncompleteEscapeSequence >>= \case+          '"' -> do+            P.effect (PM.writeByteArray dst ix (c2w '"'))+            go (ix + 1)+          '\\' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\\'))+            go (ix + 1)+          't' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\t'))+            go (ix + 1)+          'n' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\n'))+            go (ix + 1)+          'r' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\r'))+            go (ix + 1)+          '/' -> do+            P.effect (PM.writeByteArray dst ix (c2w '/'))+            go (ix + 1)+          'b' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\b'))+            go (ix + 1)+          'f' -> do+            P.effect (PM.writeByteArray dst ix (c2w '\f'))+            go (ix + 1)+          'u' -> do+            w <- Latin.hexFixedWord16 InvalidEscapeSequence+            if w >= 0xD800 && w < 0xDFFF+              then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD')+              else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w))+          _ -> P.fail InvalidEscapeSequence+        '"'# -> do+          str <- P.effect+            (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix)+          pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))+        _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c))+  go 0++encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int+encodeUtf8Char !marr !ix !c+  | c < '\128' = do+      PM.writeByteArray marr ix (c2w c)+      pure (ix + 1)+  | c < '\x0800' = do+      PM.writeByteArray marr ix+        (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000))+      PM.writeByteArray marr (ix + 1)+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))+      pure (ix + 2)+  | c <= '\xffff' = do+      PM.writeByteArray marr ix+        (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000))+      PM.writeByteArray marr (ix + 1)+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6))))+      PM.writeByteArray marr (ix + 2)+        (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c))))+      pure (ix + 3)+  | otherwise = error "encodeUtf8Char: write this"+++-- Compute the maximum number of bytes that could possibly+-- be required to house the UTF-8-encoded string once any+-- JSON escape sequences have been resolved.+-- The correctness of this hinges on the assumption that+-- the UTF-8 encoding of a character never takes up more+-- bytes than its escape sequence.+-- TODO: Something fishy is going on with escape sequences+-- in this function. Look over this again.+string :: Int -> Parser TokenException s Token+string !start = go 1 where+  go !canMemcpy = do+    P.any IncompleteString >>= \case+      92 -> P.any InvalidEscapeSequence *> go 0 -- backslash+      34 -> do -- double quote+        !pos <- Unsafe.cursor+        case canMemcpy of+          1 -> do+            src <- Unsafe.expose+            str <- P.effect $ do+              let end = pos - 1+              let len = end - start+              dst <- PM.newByteArray len+              PM.copyByteArray dst 0 src start len+              PM.unsafeFreezeByteArray dst+            pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str)))+          _ -> do+            Unsafe.unconsume (pos - start)+            let end = pos - 1+            let maxLen = end - start+            copyAndEscape maxLen+      W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##))++byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString+byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x++c2w :: Char -> Word8+c2w = fromIntegral . ord++-- Precondition: Not in the range [U+D800 .. U+DFFF]+w16ToChar :: Word16 -> Char+w16ToChar (W16# w) = C# (chr# (word2Int# w))+