Skip to content

Commit

Permalink
WIP.
Browse files Browse the repository at this point in the history 
Hit a snag where comments in `{-` and ones starting `--` are not
distinguished.
  • Loading branch information
@alanz
alanz committed Jun 4, 2023
1 parent 0ff825f commit 3851d8c
Show file tree
Hide file tree
Showing 7 changed files with 569 additions and 25 deletions.
36 changes: 20 additions & 16 deletions src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -373,7 +373,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
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 }
Expand All @@ -389,7 +389,7 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- ---------------------------------------------------------------------

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
Expand Down Expand Up @@ -430,7 +430,7 @@ flushComments trailing = do
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]
Expand Down Expand Up @@ -553,7 +553,7 @@ printStringAtAAC :: (Monad m, Monoid w)
=> 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
Expand Down Expand Up @@ -1388,7 +1388,7 @@ instance ExactPrint HsModule where

debugM "HsModule Entered"

mbDoc' <- markAnnotated mbDoc
-- mbDoc' <- markAnnotated mbDoc

(an0, mmn' , mdeprec', mexports') <-
case mmn of
Expand Down Expand Up @@ -1419,7 +1419,7 @@ instance ExactPrint HsModule where
let anf = an0 { anns = (anns an0) { am_decls = am_decls' }}
debugM $ "HsModule, anf=" ++ showAst anf

return (HsModule anf lo mmn' mexports' imports' decls' mdeprec' mbDoc')
return (HsModule anf lo mmn' mexports' imports' decls' mdeprec' mbDoc)

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -4240,7 +4240,7 @@ instance ExactPrint (ConDecl GhcPs) where
, 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
Expand All @@ -4260,7 +4260,7 @@ instance ExactPrint (ConDecl GhcPs) where
, 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
Expand All @@ -4287,7 +4287,7 @@ instance ExactPrint (ConDecl GhcPs) where
, 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
an0 <- markEpAnnL an lidl AnnDcolon
an1 <- annotationsToComments an0 lidl [AnnOpenP, AnnCloseP]
Expand All @@ -4314,7 +4314,7 @@ instance ExactPrint (ConDecl GhcPs) where
, con_names = cons'
, 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 })

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -4350,8 +4350,8 @@ instance ExactPrint (ConDeclField GhcPs) where
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)

-- ---------------------------------------------------------------------

Expand Down Expand Up @@ -4562,10 +4562,14 @@ instance ExactPrint (IE GhcPs) where
m' <- markAnnotated m
return (IEModuleContents an0 m')

-- exact (IEGroup _ _ _) = NoEntryVal
-- exact (IEDoc _ _) = NoEntryVal
-- exact (IEDocNamed _ _) = NoEntryVal
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)

-- ---------------------------------------------------------------------

Expand Down
5 changes: 3 additions & 2 deletions src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,8 +125,9 @@ getCppTokensAsComments cppOptions sourceFile = do
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


Expand Down
101 changes: 96 additions & 5 deletions src/Language/Haskell/GHC/ExactPrint/Utils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,8 +43,8 @@ import Data.Default

-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print
debugEnabledFlag :: Bool
-- debugEnabledFlag = True
debugEnabledFlag = False
debugEnabledFlag = True
-- debugEnabledFlag = False

-- |Global switch to enable debug tracing in ghc-exactprint Pretty
debugPEnabledFlag :: Bool
Expand Down Expand Up @@ -212,7 +212,13 @@ insertCppComments (L l p) cs = L l p'
-- ---------------------------------------------------------------------

ghcCommentText :: LEpaComment -> String
ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s
-- ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s
-- ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = -- "-- |" ++ s
case lines s of
[] -> ""
(x:xs) -> unlines' $ ( "-- |" ++ x)
: map (\y -> "--"++y) xs
ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNamed s) _)) = s
ghcCommentText (L _ (GHC.EpaComment (EpaDocSection _ s) _)) = s
Expand All @@ -221,8 +227,93 @@ ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s
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)
-- | Like unlines, but no trailing newline
unlines' :: [String] -> String
unlines' [] = []
unlines' [x] = x
unlines' (x:xs) = x++"\n"++unlines' xs

-- 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 t of
(L l (GHC.EpaComment (EpaDocCommentNext s) pt)) ->
case lines s of
[] -> [mkComment "" lt (ac_prior_tok c)]
(x:xs) ->
let
docChunk :: Anchor -> RealSrcSpan -> [String] -> [Comment]
docChunk _ _ [] = []
docChunk l' pt' (chunk:cs)
= Comment ( "--" ++ chunk) (addLine 0 (length x + 2) l') pt' Nothing : docChunk (addLine 1 1 l') (anchor l') cs

r = Comment ("-- |" ++ x) (addLine 0 (length x + 4) l) pt Nothing
: docChunk (addLine 1 1 l) (anchor l) xs
in
r
`debug` ("tokComment:r=" ++ showGhc r)

_ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]


addLine :: Int -> Int -> Anchor -> Anchor
addLine bump len (Anchor l op) = Anchor l' op
where
f = srcSpanFile l
sl = srcSpanStartLine l
sc = srcSpanStartCol l
el = srcSpanEndLine l
ec = srcSpanEndCol l
l' = mkRealSrcSpan (mkRealSrcLoc f (sl + bump) sc)
(mkRealSrcLoc f (sl + bump) (sc + len))

-- 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 []
Expand Down
3 changes: 2 additions & 1 deletion tests/Test.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -199,7 +199,7 @@ tt' = do

-- mkTestModChange libdir rmDecl1 "RmDecl1.hs"

mkTestModChange libdir rmDecl4 "RmDecl4.hs"
-- mkTestModChange libdir rmDecl4 "RmDecl4.hs"
-- mkParserTestMD libdir "ghc92" "Foo.hs"
-- mkParserTest libdir "ghc92" "Foo.hs"
-- mkParserTestMD libdir "ghc92" "Foo.hs"
Expand All @@ -209,6 +209,7 @@ tt' = do
-- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs"
-- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"

mkParserTest libdir "ghc92" "Haddock1.hs"
-- Needs GHC changes


Expand Down
2 changes: 1 addition & 1 deletion tests/Test/NoAnnotations.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -90,7 +90,7 @@ runPrettyRoundTrip libdir origFile !parsedOrig _cs = do
-- let !newAnns = addAnnotationsForPretty [] parsedOrig mempty
let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig
-- let comments = map tokComment $ GHC.sortRealLocated priorComments
let comments = map tokComment priorComments
let comments = concatMap tokComment priorComments
let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments
let pragmaStr = intercalate "\n" $ map commentContents pragmas

Expand Down
Loading

0 comments on commit 3851d8c

Please sign in to comment.