Support associated data decls with multiple constructors

data/15-regressions.blt

@@ -973,3 +973,12 @@ func =
 func =
   fromIntegral aaaaaaaaaaaaaaaaaaa
     / fromIntegral (aaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbb)
+
+#test multi-constructor associated data decl
+data POtfuggj
+instance BMGuwigoc POtfuggj where
+  data KVeeweknc POtfuggj r
+    = ILpieakli
+    | USilcnhkYaraposqu (WeyOoovf (Nubwlhtjd EculdW.QaeopznkAc r))
+    deriving stock (Lirylfj1, Jexr)
+    deriving anyclass Qart2.Vrzxuvcf

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs

@@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
 
 
 layoutDataDecl
-  :: LTyClDecl GhcPs
+  :: Maybe (LTyClDecl GhcPs)
   -> EpAnn [AddEpAnn]
   -> LIdP GhcPs
   -> LHsQTyVars GhcPs
@@ -53,19 +53,51 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
               , docSeparator
               , docHandleComms epAnn $ rhsDoc
               ]
-          else briDocByExactNoComment ltycl
+          else maybe
-      _ -> briDocByExactNoComment ltycl
+            (error
+            $  "Unsupported form of DataFamInstDecl:"
+            ++ " ConDeclH98 with context"
+            )
+            briDocByExactNoComment
+            ltycl
+      _ -> maybe
+            (error
+            $  "Unsupported form of DataFamInstDecl:"
+            ++ " ConDeclH98 with forall"
+            )
+            briDocByExactNoComment
+            ltycl
+  HsDataDefn NoExtField NewType _ _ Just{} _ _ -> maybe
+    (error $ "Unsupported form of DataFamInstDecl: NewType _ _ Just _ _")
+    briDocByExactNoComment
+    ltycl
+  HsDataDefn NoExtField NewType _ _ Nothing _ _ -> maybe
+    (error $ "Unsupported form of DataFamInstDecl: NewType _ _ Nothing _ _")
+    briDocByExactNoComment
+    ltycl
 
-
+  -- data MyData = MyData ..
-  -- data MyData a b
+  -- data MyData = MyData { .. }
-  -- (zero constructors)
+  HsDataDefn NoExtField DataType ctxMay _ctype Nothing conss mDerivs -> do
-  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do
     lhsContextDoc <- case ctxMay of
       Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
       Nothing -> pure docEmpty
     nameStr <- lrdrNameToTextAnn name
     tyVarLine <- return <$> createBndrDoc bndrs
     patDocs <- mapM shareDoc $ layoutHsTyPats pats
+    lhsDoc <- shareDoc $ docSeq
+      [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+        appSep $ docLitS "data"
+      , docForceSingleline $ lhsContextDoc
+      , appSep $ docLit nameStr
+      , appSep tyVarLine
+      , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+      ]
+    let prefixes = "=" : repeat "|"
+    layoutConssResult <- mapM layoutConDecl (zip prefixes conss)
+    case sequence layoutConssResult of
+      Left err -> maybe (error err) briDocByExactNoComment ltycl
+      Right [] -> do
         docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
           [ appSep $ docLitS "data"
           , lhsContextDoc
@@ -73,151 +105,140 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
           , appSep tyVarLine
           , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
           ]
-
+      Right [(consDocSl, consDocMl)] -> do
-  -- data MyData = MyData ..
-  -- data MyData = MyData { .. }
-  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
-    case cons of
-      (L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
-        -> do
-          lhsContextDoc <- case ctxMay of
-            Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
-            Nothing -> pure docEmpty
-          nameStr <- lrdrNameToTextAnn name
-          consNameStr <- lrdrNameToTextAnn consName
-          tyVarLine <- return <$> createBndrDoc bndrs
-          patDocs <- mapM shareDoc $ layoutHsTyPats pats
-          forallDocMay <- case createForallDoc qvars of
-            Nothing -> pure Nothing
-            Just x -> Just . pure <$> x
-          rhsContextDocMay <- case mRhsContext of
-            Nothing -> pure Nothing
-            Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
-          rhsDoc <- return <$> createDetailsDoc consNameStr details
-          let posEqual = obtainAnnPos epAnn AnnEqual
-          consDoc <-
-            shareDoc
-            $ docHandleComms epAnn
-            $ docHandleComms posEqual
-            $ docNonBottomSpacing
-            $ case (forallDocMay, rhsContextDocMay) of
-                (Just forallDoc, Just rhsContextDoc) -> docLines
-                  [ docSeq
-                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
-                  , docSeq
-                    [ docLitS "."
-                    , docSeparator
-                    , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
-                    ]
-                  ]
-                (Just forallDoc, Nothing) -> docLines
-                  [ docSeq
-                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
-                  , docSeq [docLitS ".", docSeparator, rhsDoc]
-                  ]
-                (Nothing, Just rhsContextDoc) -> docSeq
-                  [ docLitS "="
-                  , docSeparator
-                  , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
-                  ]
-                (Nothing, Nothing) ->
-                  docSeq [docLitS "=", docSeparator, rhsDoc]
         docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
           [ -- data D = forall a . Show a => D a
-              docSeq
+            docSeq [lhsDoc, consDocSl]
-              [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
-                docSeq
-                [ appSep $ docLitS "data"
-                , docForceSingleline $ lhsContextDoc
-                , appSep $ docLit nameStr
-                , appSep tyVarLine
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                ]
-              , docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
-              , docSeparator
-              , docSetIndentLevel $ docSeq
-                [ case forallDocMay of
-                  Nothing -> docEmpty
-                  Just forallDoc ->
-                    docSeq
-                      [ docForceSingleline forallDoc
-                      , docSeparator
-                      , docLitS "."
-                      , docSeparator
-                      ]
-                , maybe docEmpty docForceSingleline rhsContextDocMay
-                , rhsDoc
-                ]
-              ]
           , -- data D
             --   = forall a . Show a => D a
-              docAddBaseY BrIndentRegular $ docPar
+            -- data D
-              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
-                docSeq
-                [ appSep $ docLitS "data"
-                , docForceSingleline lhsContextDoc
-                , appSep $ docLit nameStr
-                , tyVarLine
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                ]
-              )
-              (docSeq
-                [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
-                , docSeparator
-                , docSetIndentLevel $ docSeq
-                  [ case forallDocMay of
-                    Nothing -> docEmpty
-                    Just forallDoc ->
-                      docSeq
-                        [ docForceSingleline forallDoc
-                        , docSeparator
-                        , docLitS "."
-                        , docSeparator
-                        ]
-                  , maybe docEmpty docForceSingleline rhsContextDocMay
-                  , rhsDoc
-                  ]
-                ]
-              )
-            , -- data D
             --   = forall a
             --   . Show a =>
             --     D a
-              docAddBaseY BrIndentRegular $ docPar
+            docAddBaseY BrIndentRegular
-              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+            $ docPar lhsDoc
-                docSeq
+              (docNonBottomSpacing $ docAlt [consDocSl, consDocMl])
-                [ appSep $ docLitS "data"
-                , docForceSingleline lhsContextDoc
-                , appSep $ docLit nameStr
-                , tyVarLine
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                ]
-              )
-              consDoc
           , -- data
             --   Show a =>
             --   D
-              --   = forall a
+            --   = rhsDoc
-              --   . Show a =>
-              --     D a
             -- This alternative is only for -XDatatypeContexts.
             -- But I think it is rather unlikely this will trigger without
             -- -XDataTypeContexts, especially with the `docNonBottomSpacing`
             -- above, so while not strictly necessary, this should not
             -- hurt.
             docAddBaseY BrIndentRegular $ docPar
-              (docLitS "data")
+            (-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
+             docLitS "data")
             (docLines
               [ lhsContextDoc
-                , -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
+              , docSeq
-                  docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
+                [ appSep $ docLit nameStr
-                , consDoc
+                , tyVarLine
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                ]
+              , consDocMl
               ]
             )
           ]
-      _ -> briDocByExactNoComment ltycl
+      Right consDocTuples -> do
+        docHandleComms declEpAnn
+          $ createDerivingPar mDerivs
+          $ docAddBaseY BrIndentRegular
+          $ docPar
+            (docAlt
+              [ -- data Show a => D a
+                lhsDoc
+              , -- data
+                --   Show a =>
+                --   D
+                -- This alternative is only for -XDatatypeContexts.
+                -- But I think it is rather unlikely this will trigger without
+                -- -XDataTypeContexts, especially with the `docNonBottomSpacing`
+                -- above, so while not strictly necessary, this should not
+                -- hurt.
+                docAddBaseY BrIndentRegular $ docPar
+                (-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
+                 docLitS "data")
+                (docLines
+                  [ lhsContextDoc
+                  , docSeq
+                    [ appSep $ docLit nameStr
+                    , tyVarLine
+                    , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                    ]
+                  ]
+                )
+              ]
+            )
+            (docLines $ [docAlt [sl, ml] | (sl, ml) <- consDocTuples])
+  
+  HsDataDefn NoExtField DataType _ _ Just{} _ _ -> maybe
+    (error $ "Unsupported form of DataFamInstDecl: DataType _ _ Just _ _")
+    briDocByExactNoComment
+    ltycl
+
+layoutConDecl
+  :: (String, LConDecl GhcPs)
+  -> ToBriDocM
+       (Either String (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered))
+layoutConDecl (prefix, L _ con) = case con of
+  ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc -> do
+    consNameStr  <- lrdrNameToTextAnn consName
+    forallDocMay <- case createForallDoc qvars of
+      Nothing -> pure Nothing
+      Just x  -> Just . pure <$> x
+    rhsContextDocMay <- case mRhsContext of
+      Nothing         -> pure Nothing
+      Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
+    detailsDoc <- shareDoc $ createDetailsDoc consNameStr details
+    let posEqual = obtainAnnPos epAnn AnnEqual
+    pure $ Right
+      ( docSeq
+          [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS prefix
+          , docSeparator
+          , docSetIndentLevel $ docSeq
+            [ case forallDocMay of
+              Nothing        -> docEmpty
+              Just forallDoc -> docSeq
+                [ docForceSingleline forallDoc
+                , docSeparator
+                , docLitS "."
+                , docSeparator
+                ]
+            , maybe docEmpty docForceSingleline rhsContextDocMay
+            , detailsDoc
+            ]
+          ]
+      , docHandleComms epAnn
+        $ docHandleComms posEqual
+        $ docNonBottomSpacing
+        $ case (forallDocMay, rhsContextDocMay) of
+            (Just forallDoc, Just rhsContextDoc) -> docLines
+              [ docSeq
+                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
+              , docSeq
+                [ docLitS "."
+                , docSeparator
+                , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
+                ]
+              ]
+            (Just forallDoc, Nothing) -> docLines
+              [ docSeq
+                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
+              , docSeq [docLitS ".", docSeparator, detailsDoc]
+              ]
+            (Nothing, Just rhsContextDoc) -> docSeq
+              [ docLitS prefix
+              , docSeparator
+              , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
+              ]
+            (Nothing, Nothing) -> docSeq
+              [docLitS prefix, docSeparator, detailsDoc]
+      )
+  ConDeclGADT{} -> pure
+    $ Left "Unsupported: ConDeclGADT inside DataFamInstDecl"
 
-  _ -> briDocByExactNoComment ltycl
 
 layoutHsTyPats
   :: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs

@@ -808,7 +808,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
                        typeDoc
   DataDecl epAnn name tyVars _ dataDefn -> do
     layouters <- mAsk
-    layout_dataDecl layouters ltycl epAnn name tyVars [] dataDefn
+    layout_dataDecl layouters (Just ltycl) epAnn name tyVars [] dataDefn
   _ -> briDocByExactNoComment ltycl
 
 layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
@@ -976,7 +976,7 @@ layoutClsInst (L declLoc _) cid = do
         layouters <- mAsk
         layout_dataDecl
           layouters
-          (error "Unsupported form of DataFamInstDecl")
+          Nothing
           epAnn
           tycon
           (case bndrs of

source/library/Language/Haskell/Brittany/Internal/Types.hs

@@ -236,7 +236,7 @@ data Layouters = Layouters
              )
          )
   , layout_dataDecl
-    :: GHC.LTyClDecl GhcPs
+    :: Maybe (GHC.LTyClDecl GhcPs)
     -> GHC.EpAnn [GHC.AddEpAnn]
     -> GHC.LIdP GhcPs
     -> GHC.LHsQTyVars GhcPs