ghc-exactprint 1.6.1.1 → 1.6.1.2

raw patch · 11 files changed

+543/−36 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog +4/−1
• ghc-exactprint.cabal +2/−1
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +46/−17
• src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +3/−2
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +48/−2
• tests/Test.hs +7/−1
• tests/Test/NoAnnotations.hs +2/−1
• tests/examples/ghc92/Foo.hs +0/−7
• tests/examples/ghc92/Foo2.hs +0/−4
• tests/examples/ghc94/Haddock.hs +408/−0
• tests/examples/ghc94/Haddock1.hs +23/−0

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

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             1.6.1.1+version:             1.6.1.2 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@@ -19,6 +19,7 @@                    , GHC == 9.4.2                    , GHC == 9.4.3                    , GHC == 9.4.4+                   , GHC == 9.4.5 extra-source-files:  ChangeLog                      tests/examples/failing/*.hs                      tests/examples/ghc710-only/*.hs

@@ -34,7 +34,8 @@   ) where  import GHC--- import GHC.Base (NonEmpty(..) )+-- import GHC.Types.SrcLoc (mkRealSrcLoc, mkRealSrcSpan)+import GHC.Base (NonEmpty(..) ) import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF@@ -76,6 +77,7 @@ import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Types+-- import GHC.Plugins (mkRealSrcLoc)  -- import Debug.Trace @@ -385,7 +387,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 }@@ -401,7 +403,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@@ -438,7 +440,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]@@ -561,7 +563,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@@ -1402,7 +1404,8 @@   exact hsmod@(HsModule EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod >> return hsmod   exact (HsModule an lo mmn mexports imports decls mdeprec mbDoc) = do -    mbDoc' <- markAnnotated mbDoc+    let mbDoc' = mbDoc+    -- mbDoc' <- markAnnotated mbDoc      (an0, mmn' , mdeprec', mexports') <-       case mmn of@@ -1541,10 +1544,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@@ -1900,11 +1920,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  -- --------------------------------------------------------------------- @@ -3959,8 +3980,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@@ -4565,7 +4586,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)  -- --------------------------------------------------------------------- @@ -5061,6 +5089,7 @@ printStringAdvance :: (Monad m, Monoid w) => String -> EP w m () printStringAdvance str = do   ss <- getAnchorU+  debugM $ "printStringAdvance: ss =" ++ showGhc ss   _ <- printStringAtRs ss str   return () 

@@ -130,8 +130,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  

@@ -38,6 +38,7 @@ import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types import Data.Default+import GHC.Base (NonEmpty(..))  -- --------------------------------------------------------------------- @@ -205,8 +206,53 @@ 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+    L lx x' = dedentDocChunkBy 4 x+    str = "-- " ++ printDecorator dec ++ 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 pt (map dedentDocChunk xs))+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 []

@@ -246,7 +246,13 @@     -- mkParserTestBC libdir "ghc92" "TopLevelSemis1.hs"     -- mkParserTestMD libdir "ghc92" "TopLevelSemis1.hs" -    mkParserTest libdir "ghc94" "HsDocTy.hs"+    -- mkParserTest libdir "ghc94" "Haddock.hs"++    -- mkParserTest libdir "ghc94" "Haddock1.hs"+    -- mkParserTestBC libdir "ghc94" "Haddock1.hs"++    -- mkParserTest libdir "ghc94" "HsDocTy.hs"+    mkParserTestBC libdir "ghc94" "HsDocTy.hs"     -- Needs GHC changes 

@@ -11,6 +11,7 @@ -- import Data.Data (Data, toConstr, showConstr, cast) -- import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List+import Data.Maybe -- import Data.Ord (comparing) -- import qualified Data.ByteString as B @@ -90,7 +91,7 @@   -- let !newAnns = addAnnotationsForPretty [] parsedOrig mempty   let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig   -- let comments = map tokComment $ GHC.sortRealLocated priorComments-  let comments = map tokComment priorComments+  let comments = concatMap tokComment priorComments   let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments   let pragmaStr = intercalate "\n" $ map commentContents pragmas 

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

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

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