Support associated data decls with multiple constructors
parent
94fcf56b28
commit
7e56701bc2
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue