ghc-exactprint 1.7.0.0 → 1.7.0.1

raw patch · 9 files changed

+558/−33 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog +3/−0
• ghc-exactprint.cabal +3/−2
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +49/−22
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +3/−2
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +53/−5
• tests/Test.hs +5/−1
• tests/Test/NoAnnotations.hs +1/−1
• tests/examples/ghc94/Haddock.hs +408/−0
• tests/examples/ghc94/Haddock1.hs +33/−0

@@ -1,3 +1,6 @@+2022-11-08 v1.7.0.1+	* Add CI for GHC 9.6.2+	* Correctly deal with comments when using GHC flag -haddock 2022-11-08 v1.7 	* Support GHC 9.6.1 2022-11-08 v1.6.1

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             1.7.0.0+version:             1.7.0.1 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@@ -15,7 +15,8 @@ maintainer:          alan.zimm@gmail.com category:            Development build-type:          Simple-tested-with:         GHC == 9.6.1+tested-with:         GHC == 9.6.1,+                     GHC == 9.6.2 extra-source-files:  ChangeLog                      tests/examples/failing/*.hs                      tests/examples/ghc710-only/*.hs

@@ -52,6 +52,7 @@ 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(..)) @@ -384,7 +385,7 @@   when (flush == NoFlushComments) $ do     when ((getFollowingComments cs) /= []) $ do       debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs)-      mapM_ printOneComment (map tokComment $ getFollowingComments cs)+      mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs)       debugM $ "ending trailing comments"    let newAchor = anchor' { anchor_op = MovedAnchor edp }@@ -400,7 +401,7 @@ -- ---------------------------------------------------------------------  addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m ()-addCommentsA csNew = addComments (map tokComment csNew)+addCommentsA csNew = addComments (concatMap tokComment csNew)  {- TODO: When we addComments, some may have an anchor that is no longer@@ -437,7 +438,7 @@   mapM_ printOneComment (sortComments cs)   debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing)   debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing)-  mapM_ printOneComment (map tokComment (filterEofComment True trailing))+  mapM_ printOneComment (concatMap tokComment (filterEofComment True trailing))   debugM $ "flushing comments done"  filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment]@@ -565,7 +566,7 @@   => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s printStringAtAAC capture (EpaDelta d cs) s = do-  mapM_ (printOneComment . tokComment) cs+  mapM_  printOneComment $ concatMap tokComment cs   pe1 <- getPriorEndD   p1 <- getPosP   printStringAtLsDelta d s@@ -1389,7 +1390,8 @@   exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod   exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do -    mbDoc' <- markAnnotated mbDoc+    let mbDoc' = mbDoc+    -- mbDoc' <- markAnnotated mbDoc      (an0, mmn' , mdeprec', mexports') <-       case mmn of@@ -1529,10 +1531,27 @@ 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+    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++ instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where   getAnnotationEntry _ = NoEntryVal   setAnnotationAnchor a _ _ = a@@ -1888,11 +1907,12 @@   getAnnotationEntry = const NoEntryVal   setAnnotationAnchor a _ _ = a -  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 = 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  -- --------------------------------------------------------------------- @@ -3922,8 +3942,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@@ -4221,7 +4241,7 @@                     , con_mb_cxt = mcxt                     , con_args = args                     , con_doc = doc }) = do-    doc' <- mapM markAnnotated doc+    -- doc' <- mapM markAnnotated doc     an0 <- if has_forall       then markEpAnnL an lidl AnnForall       else return an@@ -4241,7 +4261,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@@ -4269,7 +4289,7 @@                      , con_bndrs = bndrs                      , con_mb_cxt = mcxt, con_g_args = args                      , con_res_ty = res_ty, con_doc = doc }) = do-    doc' <- mapM markAnnotated doc+    -- doc' <- mapM markAnnotated doc     cons' <- mapM markAnnotated cons     dcol' <- markUniToken dcol     an1 <- annotationsToComments an lidl  [AnnOpenP, AnnCloseP]@@ -4298,7 +4318,7 @@                         , 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 })  -- --------------------------------------------------------------------- @@ -4334,8 +4354,8 @@     names' <- markAnnotated names     an0 <- markEpAnnL an lidl AnnDcolon     ftype' <- markAnnotated ftype-    mdoc' <- mapM markAnnotated mdoc-    return (ConDeclField an0 names' ftype' mdoc')+    -- mdoc' <- mapM markAnnotated mdoc+    return (ConDeclField an0 names' ftype' mdoc)  -- --------------------------------------------------------------------- @@ -4533,7 +4553,14 @@     m' <- markAnnotated m     return (IEModuleContents an0 m') -  exact x = error $ "missing match for IE:" ++ showAst x+  -- 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)  -- --------------------------------------------------------------------- 

@@ -126,8 +126,9 @@ goodComment :: GHC.LEpaComment -> Bool goodComment c = isGoodComment (tokComment c)   where-    isGoodComment :: Comment -> Bool-    isGoodComment (Comment "" _ _ _) = False+    isGoodComment :: [Comment] -> Bool+    isGoodComment []                 = False+    isGoodComment [Comment "" _ _ _] = False     isGoodComment _                  = True  

@@ -37,6 +37,7 @@ import GHC.Driver.Ppr import GHC.Data.FastString import qualified GHC.Data.Strict as Strict+import GHC.Base (NonEmpty(..))  import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types@@ -214,9 +215,58 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _))    = s ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _))        = "" -tokComment :: LEpaComment -> Comment-tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c)+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 '*'+++ mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments mkEpaComments priorCs []   = EpaComments (map comment2LEpaComment priorCs)@@ -235,9 +285,7 @@  -- Windows comments include \r in them from the lexer. normaliseCommentText :: String -> String-normaliseCommentText [] = []-normaliseCommentText ('\r':xs) = normaliseCommentText xs-normaliseCommentText (x:xs) = x:normaliseCommentText xs+normaliseCommentText = filter (/= '\r')  -- |Must compare without span filenames, for CPP injected comments with fake filename cmpComments :: Comment -> Comment -> Ordering

@@ -247,7 +247,11 @@     -- mkParserTest libdir "ghc96" "T11671_run.hs"      -- mkParserTest libdir "ghc96" "LexerM.hs"-    mkParserTestBC libdir "ghc96" "LexerM.hs"+    -- mkParserTestBC libdir "ghc96" "LexerM.hs"++    -- mkParserTest libdir "ghc94" "Haddock.hs"+    -- mkParserTest libdir "ghc94" "Haddock1.hs"+    mkParserTestBC libdir "ghc94" "Haddock1.hs"     -- Needs GHC changes 

@@ -89,7 +89,7 @@ runPrettyRoundTrip libdir origFile !parsedOrig _cs = do   let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn         $ GHC.hsmodExt $ GHC.unLoc parsedOrig-  let comments = map tokComment priorComments+  let comments = concatMap tokComment priorComments   let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments   let pragmaStr = intercalate "\n" $ map commentContents pragmas 

@@ -0,0 +1,408 @@+{-# 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

@@ -0,0 +1,33 @@+{-# 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++        -- * A section+        -- and without an intervening comma:+        -- ** A subsection+   ) where++-- | Haddock before imports+import Data.List++-- | Haddock before decl+f = undefined+g = undefined++-- | 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) -- ^