diff --git a/data/15-regressions.blt b/data/15-regressions.blt index 6bc82cd..0901cc4 100644 --- a/data/15-regressions.blt +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs index 6c6e6d6..59f81fb 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs +++ b/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 - _ -> briDocByExactNoComment ltycl + else maybe + (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 a b - -- (zero constructors) - HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do + -- data MyData = MyData .. + -- data MyData = MyData { .. } + HsDataDefn NoExtField DataType ctxMay _ctype Nothing conss 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 - [ appSep $ docLitS "data" - , lhsContextDoc + 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]] ] - - -- 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] + 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 + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] + ] + Right [(consDocSl, consDocMl)] -> do + docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq [lhsDoc, consDocSl] + , -- data D + -- = forall a . Show a => D a + -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular + $ docPar lhsDoc + (docNonBottomSpacing $ docAlt [consDocSl, consDocMl]) + , -- data + -- Show a => + -- D + -- = rhsDoc + -- 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]] + ] + , 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 "." - , docSeparator - , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + [ appSep $ docLit nameStr + , tyVarLine + , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]] ] ] - (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 - [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ - docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep 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 ] - , 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 + , 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] ] ] - , -- 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]] - ] - ) - (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 - ( -- 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 + (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] diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs index 5910999..9798601 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/Decl.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Types.hs index 0e0bd87..83888b0 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Types.hs +++ b/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