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,171 +53,192 @@ 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
-    docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
+    lhsDoc <- shareDoc $ docSeq
-      [ appSep $ docLitS "data"
+      [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
-      , lhsContextDoc
+        appSep $ docLitS "data"
+      , docForceSingleline $ lhsContextDoc
       , appSep $ docLit nameStr
       , appSep tyVarLine
       , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
       ]
-
+    let prefixes = "=" : repeat "|"
-  -- data MyData = MyData ..
+    layoutConssResult <- mapM layoutConDecl (zip prefixes conss)
-  -- data MyData = MyData { .. }
+    case sequence layoutConssResult of
-  HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
+      Left err -> maybe (error err) briDocByExactNoComment ltycl
-    case cons of
+      Right [] -> do
-      (L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
+        docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
-        -> do
+          [ appSep $ docLitS "data"
-          lhsContextDoc <- case ctxMay of
+          , lhsContextDoc
-            Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
+          , appSep $ docLit nameStr
-            Nothing -> pure docEmpty
+          , appSep tyVarLine
-          nameStr <- lrdrNameToTextAnn name
+          , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-          consNameStr <- lrdrNameToTextAnn consName
+          ]
-          tyVarLine <- return <$> createBndrDoc bndrs
+      Right [(consDocSl, consDocMl)] -> do
-          patDocs <- mapM shareDoc $ layoutHsTyPats pats
+        docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
-          forallDocMay <- case createForallDoc qvars of
+          [ -- data D = forall a . Show a => D a
-            Nothing -> pure Nothing
+            docSeq [lhsDoc, consDocSl]
-            Just x -> Just . pure <$> x
+          , -- data D
-          rhsContextDocMay <- case mRhsContext of
+            --   = forall a . Show a => D a
-            Nothing -> pure Nothing
+            -- data D
-            Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
+            --   = forall a
-          rhsDoc <- return <$> createDetailsDoc consNameStr details
+            --   . Show a =>
-          let posEqual = obtainAnnPos epAnn AnnEqual
+            --     D a
-          consDoc <-
+            docAddBaseY BrIndentRegular
-            shareDoc
+            $ docPar lhsDoc
-            $ docHandleComms epAnn
+              (docNonBottomSpacing $ docAlt [consDocSl, consDocMl])
-            $ docHandleComms posEqual
+          , -- data
-            $ docNonBottomSpacing
+            --   Show a =>
-            $ case (forallDocMay, rhsContextDocMay) of
+            --   D
-                (Just forallDoc, Just rhsContextDoc) -> docLines
+            --   = rhsDoc
-                  [ docSeq
+            -- This alternative is only for -XDatatypeContexts.
-                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
+            -- 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]]
+                ]
+              , consDocMl
+              ]
+            )
+          ]
+      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
-                    [ docLitS "."
+                    [ appSep $ docLit nameStr
-                    , docSeparator
+                    , tyVarLine
-                    , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
+                    , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
                     ]
                   ]
-                (Just forallDoc, Nothing) -> docLines
+                )
-                  [ docSeq
+              ]
-                    [docLitS "=", docSeparator, docForceSingleline forallDoc]
+            )
-                  , docSeq [docLitS ".", docSeparator, rhsDoc]
+            (docLines $ [docAlt [sl, ml] | (sl, ml) <- consDocTuples])
-                  ]
+  
-                (Nothing, Just rhsContextDoc) -> docSeq
+  HsDataDefn NoExtField DataType _ _ Just{} _ _ -> maybe
-                  [ docLitS "="
+    (error $ "Unsupported form of DataFamInstDecl: DataType _ _ Just _ _")
-                  , docSeparator
+    briDocByExactNoComment
-                  , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
+    ltycl
-                  ]
+
-                (Nothing, Nothing) ->
+layoutConDecl
-                  docSeq [docLitS "=", docSeparator, rhsDoc]
+  :: (String, LConDecl GhcPs)
-          docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
+  -> ToBriDocM
-            [ -- data D = forall a . Show a => D a
+       (Either String (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered))
-              docSeq
+layoutConDecl (prefix, L _ con) = case con of
-              [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+  ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc -> do
-                docSeq
+    consNameStr  <- lrdrNameToTextAnn consName
-                [ appSep $ docLitS "data"
+    forallDocMay <- case createForallDoc qvars of
-                , docForceSingleline $ lhsContextDoc
+      Nothing -> pure Nothing
-                , appSep $ docLit nameStr
+      Just x  -> Just . pure <$> x
-                , appSep tyVarLine
+    rhsContextDocMay <- case mRhsContext of
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+      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
                 ]
-              , docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
+            , maybe docEmpty docForceSingleline rhsContextDocMay
-              , docSeparator
+            , detailsDoc
-              , docSetIndentLevel $ docSeq
+            ]
-                [ case forallDocMay of
+          ]
-                  Nothing -> docEmpty
+      , docHandleComms epAnn
-                  Just forallDoc ->
+        $ docHandleComms posEqual
-                    docSeq
+        $ docNonBottomSpacing
-                      [ docForceSingleline forallDoc
+        $ case (forallDocMay, rhsContextDocMay) of
-                      , docSeparator
+            (Just forallDoc, Just rhsContextDoc) -> docLines
-                      , docLitS "."
+              [ docSeq
-                      , docSeparator
+                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
-                      ]
+              , docSeq
-                , maybe docEmpty docForceSingleline rhsContextDocMay
+                [ docLitS "."
-                , rhsDoc
+                , docSeparator
+                , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
                 ]
               ]
-            , -- data D
+            (Just forallDoc, Nothing) -> docLines
-              --   = forall a . Show a => D a
+              [ docSeq
-              docAddBaseY BrIndentRegular $ docPar
+                [docLitS prefix, docSeparator, docForceSingleline forallDoc]
-              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
+              , docSeq [docLitS ".", docSeparator, detailsDoc]
-                docSeq
+              ]
-                [ appSep $ docLitS "data"
+            (Nothing, Just rhsContextDoc) -> docSeq
-                , docForceSingleline lhsContextDoc
+              [ docLitS prefix
-                , appSep $ docLit nameStr
+              , docSeparator
-                , tyVarLine
+              , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+              ]
-                ]
+            (Nothing, Nothing) -> docSeq
-              )
+              [docLitS prefix, docSeparator, detailsDoc]
-              (docSeq
+      )
-                [ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
+  ConDeclGADT{} -> pure
-                , docSeparator
+    $ Left "Unsupported: ConDeclGADT inside DataFamInstDecl"
-                , 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
-              ( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
-                docSeq
-                [ appSep $ docLitS "data"
-                , docForceSingleline lhsContextDoc
-                , appSep $ docLit nameStr
-                , tyVarLine
-                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-                ]
-              )
-              consDoc
-            , -- data
-              --   Show a =>
-              --   D
-              --   = forall a
-              --   . 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")
-              (docLines
-                [ lhsContextDoc
-                , -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
-                  docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
-                , consDoc
-                ]
-              )
-            ]
-      _ -> briDocByExactNoComment ltycl
 
-  _ -> 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