Merge pull request #198 from ruhatch/type-synonyms

src-literatetests/10-tests.blt

@@ -1155,3 +1155,44 @@ func = do
 
   other :: Other
   other = True
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group typefam.instance
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test simple-typefam-instance
+
+type instance MyFam Bool = String
+
+#test simple-typefam-instance-param-type
+
+type instance MyFam (Maybe a) = a -> Bool
+
+#test simple-typefam-instance-parens
+
+type instance (MyFam (String -> Int)) = String
+
+#test simple-typefam-instance-overflow
+
+type instance MyFam ALongishType
+  =  AMuchLongerTypeThanThat
+  -> AnEvenLongerTypeThanTheLastOne
+  -> ShouldDefinitelyOverflow
+
+#test simple-typefam-instance-comments
+
+-- | A happy family
+type instance MyFam Bool -- This is an odd one
+  = AnotherType -- Here's another
+
+#test simple-typefam-instance-parens-comment
+
+-- | A happy family
+type instance (MyFam Bool) -- This is an odd one
+  = -- Here's another
+    AnotherType

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -9,6 +9,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
   , askIndent
   , extractAllComments
+  , extractRestComments
   , filterAnns
   , docEmpty
   , docLit
@@ -64,6 +65,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , hasAnyCommentsBelow
   , hasAnyCommentsConnected
   , hasAnyCommentsPrior
+  , hasAnyRegularCommentsConnected
+  , hasAnyRegularCommentsRest
   , hasAnnKeywordComment
   , hasAnnKeyword
   )
@@ -263,9 +266,13 @@ askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
 extractAllComments
   :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
 extractAllComments ann =
-  ExactPrint.annPriorComments ann
+  ExactPrint.annPriorComments ann ++ extractRestComments ann
-    ++ ExactPrint.annFollowingComments ann
+
-    ++ ( ExactPrint.annsDP ann >>= \case
+extractRestComments
+  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
+extractRestComments ann =
+  ExactPrint.annFollowingComments ann
+    ++ (ExactPrint.annsDP ann >>= \case
          (ExactPrint.AnnComment com, dp) -> [(com, dp)]
          _                               -> []
        )
@@ -278,31 +285,51 @@ filterAnns ast =
 -- a) connected to any node below (in AST sense) the given node AND
 -- b) after (in source code order) the node.
 hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsBelow ast@(L l _) = do
+hasAnyCommentsBelow ast@(L l _) =
-  anns <- filterAnns ast <$> mAsk
+  List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
-  return
+    <$> astConnectedComments ast
-    $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
-    $ (=<<) extractAllComments
-    $ Map.elems
-    $ anns
 
--- | True if there are any comments that are
+-- | True if there are any comments that are connected to any node below (in AST
--- connected to any node below (in AST sense) the given node
+--   sense) the given node
 hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
-hasAnyCommentsConnected ast = do
+hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
+
+-- | True if there are any regular comments connected to any node below (in AST
+--   sense) the given node
+hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsConnected ast =
+  any isRegularComment <$> astConnectedComments ast
+
+-- | Regular comments are comments that are actually "source code comments",
+-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
+-- used by ghc-exactprint for capturing symbols (and their exact positioning).
+--
+-- Only the type instance layouter makes use of this filter currently, but
+-- it might make sense to apply it more aggressively or make it the default -
+-- I believe that most of the time we branch on the existence of comments, we
+-- only care about "regular" comments. We simply did not need the distinction
+-- because "irregular" comments are not that common outside of type/data decls.
+isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
+isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
+
+astConnectedComments
+  :: Data ast
+  => GHC.Located ast
+  -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
+astConnectedComments ast = do
   anns <- filterAnns ast <$> mAsk
-  return
+  pure $ extractAllComments =<< Map.elems anns
-    $ not
-    $ null
-    $ (=<<) extractAllComments
-    $ 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
 
+hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
+hasAnyRegularCommentsRest ast = astAnn ast <&> \case
+  Nothing -> False
+  Just ann -> any isRegularComment (extractRestComments ann)
+
 hasAnnKeywordComment
   :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
 hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case

src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs

@@ -33,6 +33,9 @@ import           GHC                            ( runGhc
                                                 )
 import           SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
 import           HsSyn
+#if MIN_VERSION_ghc(8,6,0)
+import           HsExtension (NoExt (..))
+#endif
 import           Name
 import           BasicTypes ( InlinePragma(..)
                             , Activation(..)
@@ -62,7 +65,8 @@ layoutDecl d@(L loc decl) = case decl of
     Left  ns -> docLines $ return <$> ns
     Right n  -> return n
   TyClD _ tycl           -> withTransformedAnns d $ layoutTyCl (L loc tycl)
-  InstD _ (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
+  InstD _ (TyFamInstD _ tfid) ->
+    withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)
   InstD _ (ClsInstD _ inst) ->
     withTransformedAnns d $ layoutClsInst (L loc inst)
   _ -> briDocByExactNoComment d
@@ -73,25 +77,12 @@ layoutDecl d@(L loc decl) = case decl of
     Left  ns -> docLines $ return <$> ns
     Right n  -> return n
   TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)
-  InstD (TyFamInstD{}) -> layoutTyFamInstDWorkaround d
+  InstD (TyFamInstD tfid) ->
+    withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid)
   InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst)
   _                    -> briDocByExactNoComment d
 #endif
 
-layoutTyFamInstDWorkaround :: ToBriDoc HsDecl
-layoutTyFamInstDWorkaround d = do
-  -- this is a (temporary (..)) workaround for "type instance" decls
-  -- that do not round-trip through exactprint properly.
-  let fixer s = case List.stripPrefix "type " s of
-        Just rest | not ("instance" `isPrefixOf` rest) ->
-          "type instance " ++ rest
-        _ -> s
-  str <- mAsk <&> \anns ->
-    intercalate "\n" $ fmap fixer $ lines' $ ExactPrint.exactPrint d anns
-  allocateNode $ BDFExternal (ExactPrint.mkAnnKey d)
-                             (foldedAnnKeys d)
-                             False
-                             (Text.pack str)
 
 --------------------------------------------------------------------------------
 -- Sig
@@ -156,24 +147,11 @@ layoutSig lsig@(L _loc sig) = case sig of
             ]
           ]
         ]
-      else
+      else layoutLhsAndType
-        docAlt
+        hasComments
-          $  [ docSeq
+        (appSep . docWrapNodeRest lsig $ docLit nameStr)
-               [ appSep $ docWrapNodeRest lsig $ docLit nameStr
+        "::"
-               , appSep $ docLit $ Text.pack "::"
+        typeDoc
-               , docForceSingleline typeDoc
-               ]
-             | not hasComments
-             ]
-          ++ [ docAddBaseY BrIndentRegular $ docPar
-               (docWrapNodeRest lsig $ docLit nameStr)
-               ( docCols
-                 ColTyOpPrefix
-                 [ docLit $ Text.pack ":: "
-                 , docAddBaseY (BrIndentSpecial 3) $ typeDoc
-                 ]
-               )
-             ]
 
 specStringCompat
   :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
@@ -754,12 +732,7 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
   sharedLhs   <- docSharedWrapper id lhs
   typeDoc     <- docSharedWrapper layoutType typ
   hasComments <- hasAnyCommentsConnected typ
-  runFilteredAlternative $ do
+  layoutLhsAndType hasComments sharedLhs "=" typeDoc
-    addAlternativeCond (not hasComments) $ docSeq
-      [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc]
-    addAlternative $ docAddBaseY BrIndentRegular $ docPar
-      sharedLhs
-      (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc])
 
 layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr
 layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
@@ -788,6 +761,55 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
            ]
 
 
+--------------------------------------------------------------------------------
+-- TyFamInstDecl
+--------------------------------------------------------------------------------
+
+layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl
+layoutTyFamInstDecl inClass (L loc tfid) = do
+  let
+#if MIN_VERSION_ghc(8,6,0)
+    linst = L loc (TyFamInstD NoExt tfid)
+    feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid
+    lfeqn = L loc feqn
+#elif MIN_VERSION_ghc(8,4,0)
+    linst = L loc (TyFamInstD tfid)
+    feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid
+    lfeqn = L loc feqn
+#elif MIN_VERSION_ghc(8,2,0)
+    linst = L loc (TyFamInstD tfid)
+    lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid
+    pats = hsib_body boundPats
+#else
+    linst = L loc (TyFamInstD tfid)
+    lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid
+    pats = hsib_body boundPats
+#endif
+  docWrapNodePrior linst $ do
+    nameStr   <- lrdrNameToTextAnn name
+    needsParens <- hasAnnKeyword lfeqn AnnOpenP
+    let
+      instanceDoc = if inClass
+        then docLit $ Text.pack "type"
+        else docSeq
+          [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]
+      lhs =
+        docWrapNode lfeqn
+          .  appSep
+          .  docWrapNodeRest linst
+          .  docSeq
+          $  (appSep instanceDoc :)
+          $  [ docParenL | needsParens ]
+          ++ [appSep $ docWrapNode name $ docLit nameStr]
+          ++ intersperse docSeparator (layoutType <$> pats)
+          ++ [ docParenR | needsParens ]
+    hasComments <- (||)
+      <$> hasAnyRegularCommentsConnected lfeqn
+      <*> hasAnyRegularCommentsRest linst
+    typeDoc <- docSharedWrapper layoutType typ
+    layoutLhsAndType hasComments lhs "=" typeDoc
+
+
 --------------------------------------------------------------------------------
 -- ClsInstDecl
 --------------------------------------------------------------------------------
@@ -855,12 +877,7 @@ layoutClsInst lcid@(L _ cid) = docLines
   layoutAndLocateTyFamInsts
     :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)
   layoutAndLocateTyFamInsts ltfid@(L loc _) =
-    L loc <$> layoutTyFamInstDecl ltfid
+    L loc <$> layoutTyFamInstDecl True ltfid
-
-  -- | Send to ExactPrint then remove unecessary whitespace
-  layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl
-  layoutTyFamInstDecl ltfid =
-    fmap stripWhitespace <$> briDocByExactNoComment ltfid
 
   layoutAndLocateDataFamInsts
     :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)
@@ -928,3 +945,32 @@ layoutClsInst lcid@(L _ cid) = docLines
     isTypeOrData t' =
       (Text.pack "type" `Text.isPrefixOf` t')
         || (Text.pack "data" `Text.isPrefixOf` t')
+
+
+--------------------------------------------------------------------------------
+-- Common Helpers
+--------------------------------------------------------------------------------
+
+layoutLhsAndType
+  :: Bool
+  -> ToBriDocM BriDocNumbered
+  -> String
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
+layoutLhsAndType hasComments lhs sep typeDoc = do
+  let sepDoc = appSep . docLit $ Text.pack sep
+  runFilteredAlternative $ do
+    -- (separators probably are "=" or "::")
+    -- lhs = type
+    -- lhs :: type
+    addAlternativeCond (not hasComments)
+      $ docSeq [lhs, sepDoc, docForceSingleline typeDoc]
+    -- lhs
+    --   :: typeA
+    --   -> typeB
+    -- lhs
+    --   =  typeA
+    --   -> typeB
+    addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols
+      ColTyOpPrefix
+      [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc]