From e7d8b5f1abdd3539c1b2f6bae1f01bfa33f4230d Mon Sep 17 00:00:00 2001
From: Rupert Horlick <rupert.horlick@iohk.io>
Date: Fri, 19 Oct 2018 15:32:37 -0400
Subject: [PATCH] Fix type synonym comments

---
 src-literatetests/10-tests.blt                |  1 -
 .../Brittany/Internal/LayouterBasics.hs       | 33 +++++++++-----
 .../Brittany/Internal/Layouters/Decl.hs       | 45 ++++++++++---------
 3 files changed, 45 insertions(+), 34 deletions(-)

diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt
index f2b02d8..83dfc61 100644
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -983,7 +983,6 @@ type a :+: b = (a, b)
 type (a `Foo` b) c = (a, b, c)
 
 #test synonym-comments
-#pending
 
 type Foo a -- fancy type comment
   = -- strange comment
diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 9f6366e..458f7ed 100644
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -63,6 +63,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , docSharedWrapper
   , hasAnyCommentsBelow
   , hasAnyCommentsConnected
+  , hasAnyCommentsPrior
   , hasAnnKeywordComment
   , hasAnnKeyword
   )
@@ -297,13 +298,16 @@ hasAnyCommentsConnected ast = do
     $ Map.elems
     $ anns
 
+hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyCommentsPrior ast = astAnn ast <&> \case
+  Nothing -> False
+  Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
+
 hasAnnKeywordComment
   :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
-hasAnnKeywordComment ast annKeyword = do
-  anns <- mAsk
-  pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
-    Nothing  -> False
-    Just ann -> any hasK (extractAllComments ann)
+hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
+  Nothing  -> False
+  Just ann -> any hasK (extractAllComments ann)
   where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
 
 hasAnnKeyword
@@ -311,13 +315,18 @@ hasAnnKeyword
   => Located a
   -> AnnKeywordId
   -> m Bool
-hasAnnKeyword ast annKeyword = do
-  anns <- mAsk
-  let hasK (ExactPrint.Types.G x, _) = x == annKeyword
-      hasK _                         = False
-  pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
-    Nothing -> False
-    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+hasAnnKeyword ast annKeyword = astAnn ast <&> \case
+  Nothing -> False
+  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
+ where
+  hasK (ExactPrint.Types.G x, _) = x == annKeyword
+  hasK _                         = False
+
+astAnn
+  :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
+  => GHC.Located ast
+  -> m (Maybe Annotation)
+astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
 
 -- new BriDoc stuff
 
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
index 4576e48..7f37282 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
@@ -633,12 +633,13 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
           Just (c, _) -> not (c == '(' || isUpper c)
     isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote
 #endif
-    hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
-    let parenWrapper = if hasTrailingParen
-          then appSep . docWrapNodeRest ltycl
-          else id
+    -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
+    -- let parenWrapper = if hasTrailingParen
+    --       then appSep . docWrapNodeRest ltycl
+    --       else id
+    let wrapNodeRest = docWrapNodeRest ltycl
     docWrapNodePrior ltycl
-      $ layoutSynDecl isInfix parenWrapper name (hsq_explicit vars) typ
+      $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ
   _ -> briDocByExactNoComment ltycl
 
 layoutSynDecl
@@ -648,17 +649,16 @@ layoutSynDecl
   -> [LHsTyVarBndr GhcPs]
   -> LHsType GhcPs
   -> ToBriDocM BriDocNumbered
-layoutSynDecl isInfix parenWrapper name vars typ = do
+layoutSynDecl isInfix wrapNodeRest name vars typ = do
   nameStr <- lrdrNameToTextAnn name
   let
-    lhs = if isInfix
+    lhs = appSep . wrapNodeRest $ if isInfix
       then do
-        let
-          (a : b : rest) = vars
+        let (a : b : rest) = vars
         hasOwnParens <- hasAnnKeywordComment a AnnOpenP
-          -- This isn't quite right, but does give syntactically valid results
+        -- This isn't quite right, but does give syntactically valid results
         let needsParens = not $ null rest || hasOwnParens
-        parenWrapper . docSeq
+        docSeq
           $  [ appSep $ docLit $ Text.pack "type"
              , appSep
              .  docSeq
@@ -672,18 +672,21 @@ layoutSynDecl isInfix parenWrapper name vars typ = do
           ++ fmap (appSep . layoutTyVarBndr) rest
       else
         docSeq
-        $  [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr]
+        $  [ appSep $ docLit $ Text.pack "type"
+           , appSep $ docWrapNode name $ docLit nameStr
+           ]
         ++ fmap (appSep . layoutTyVarBndr) vars
-  typeDoc <- docSharedWrapper layoutType typ
+  typeDoc     <- docSharedWrapper layoutType typ
+  hasComments <- hasAnyCommentsConnected typ
   docAlt
-    [ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc]
-    , docAddBaseY BrIndentRegular $ docPar
-      lhs
-      (docCols
-        ColTyOpPrefix
-        [docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc]
-      )
-    ]
+    $  [ docSeq
+           [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc]
+       | not hasComments
+       ]
+    ++ [ docAddBaseY BrIndentRegular $ docPar
+          lhs
+          (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc])
+       ]
 
 layoutTyVarBndr :: ToBriDoc HsTyVarBndr
 layoutTyVarBndr lbndr@(L _ bndr) = do