From 825df2cc31869814ad7e3bb9383c7b357d178aae Mon Sep 17 00:00:00 2001
From: Alan Zimmerman <alan.zimm@gmail.com>
Date: Mon, 7 Aug 2023 18:36:18 +0100
Subject: [PATCH] WIP

---
 .../Haskell/GHC/ExactPrint/ExactPrint.hs      |  4 +-
 src/Language/Haskell/GHC/ExactPrint/Utils.hs  | 71 ++++++++++++++-----
 tests/Test.hs                                 |  3 +-
 tests/examples/ghc92/Haddock1.hs              |  5 +-
 4 files changed, 62 insertions(+), 21 deletions(-)

diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
index 7575f3bc..6383dce7 100644
--- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs
@@ -3958,7 +3958,9 @@ instance ExactPrint (HsType GhcPs) where
   exact (HsSpliceTy a splice) = do
     splice' <- markAnnotated splice
     return (HsSpliceTy a splice')
-  -- exact x@(HsDocTy an _ _)          = withPpr x
+  exact (HsDocTy an ty doc) = do
+    ty' <- markAnnotated ty
+    return (HsDocTy an ty' doc)
   exact (HsBangTy an (HsSrcBang mt up str) ty) = do
     an0 <-
       case mt of
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
index 7c2b5e7b..ce27303c 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -233,31 +233,68 @@ 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)
+      if isDocCommentNextNested s l
+        then epaDocCommentNextNested s l pt
+        else epaDocCommentNextNonNested s l pt
+
+    (L l (GHC.EpaComment (EpaDocCommentPrev s) pt))  ->
+     [mkComment ("-- ^" ++ s) l pt]
 
+    (L l (GHC.EpaComment (EpaDocSection n s) pt))  ->
+     [mkComment ("-- " ++ replicate n '*' ++ s) l pt]
     _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)]
 
 
+-- | Try to work out if the original comment was using "--" or "{-" "-}".
+-- Note: this is impossible for a comment against the left margin (like this one).
+isDocCommentNextNested :: String -> Anchor -> Bool
+isDocCommentNextNested s (Anchor r _)
+  = case lines s of
+      [] -> True
+      [x] -> -- Single line, check span length vs string length
+        let
+          start_col = srcSpanStartCol r
+          end_col = srcSpanEndCol r
+          -- "--|" vs "{-|-}"
+          res = (end_col - start_col - length x) /= 4
+        in
+          res
+            `debug` ("isDocCommentNextNested: (length x, start_col, end_col)" ++ show (length x, start_col, end_col))
+      xs -> -- multi-line. For last line, see if the end col aligns
+            -- with starting at the left and adding `-}`
+        let
+          line = last xs
+          end_col = srcSpanEndCol r
+          res = length line + 3 == end_col
+        in
+          res
+            `debug` ("isDocCommentNextNested: (length line, end_col)" ++ show (length line, end_col))
+
+epaDocCommentNextNested :: String -> Anchor -> RealSrcSpan -> [Comment]
+epaDocCommentNextNested s l pt
+  = [Comment ("{-|" ++ s ++ "-}") (addLine 0 (length s + 3) l) pt Nothing]
+
+epaDocCommentNextNonNested :: String -> Anchor -> RealSrcSpan -> [Comment]
+epaDocCommentNextNonNested s l pt
+  = case lines s of
+      [] -> [mkComment "" l pt]
+      (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)
+
 addLine :: Int -> Int -> Anchor -> Anchor
 addLine  bump len (Anchor l op) = Anchor l' op
   where
diff --git a/tests/Test.hs b/tests/Test.hs
index a0d5ec13..26c005e8 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -209,7 +209,8 @@ tt' = do
     -- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs"
     -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs"
 
-    mkParserTest libdir      "ghc92" "Haddock1.hs"
+    -- mkParserTest libdir      "ghc92" "Haddock1.hs"
+    mkParserTest libdir      "ghc92" "Haddock.hs"
    -- Needs GHC changes
 
 
diff --git a/tests/examples/ghc92/Haddock1.hs b/tests/examples/ghc92/Haddock1.hs
index 4dc7c928..7679c92d 100644
--- a/tests/examples/ghc92/Haddock1.hs
+++ b/tests/examples/ghc92/Haddock1.hs
@@ -15,7 +15,8 @@ module Haddock1 (
 
         {-| nested-style doc comments,
             multi-line
-        -}
+  blah
+       -}
         , h
 
         -- * A section
@@ -26,7 +27,7 @@ module Haddock1 (
 -- | Haddock before imports
 import Data.List
 
--- | Haddock before decl
+--  | Haddock before decl
 f = undefined
 g = undefined
 h = undefined