354 lines
12 KiB
Haskell
354 lines
12 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.Layouters.DataDecl
|
|
( layoutDataDecl
|
|
)
|
|
where
|
|
|
|
|
|
|
|
#include "prelude.inc"
|
|
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.LayouterBasics
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
|
|
import RdrName ( RdrName(..) )
|
|
import GHC ( Located, runGhc, GenLocated(L), moduleNameString )
|
|
import qualified GHC
|
|
import HsSyn
|
|
import Name
|
|
import BasicTypes
|
|
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
|
|
|
|
import Language.Haskell.Brittany.Internal.Layouters.Type
|
|
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
|
|
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
|
|
import Language.Haskell.Brittany.Internal.Layouters.Pattern
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
|
|
import Bag ( mapBagM )
|
|
|
|
|
|
|
|
layoutDataDecl
|
|
:: Located (TyClDecl GhcPs)
|
|
-> Located RdrName
|
|
-> LHsQTyVars GhcPs
|
|
-> HsDataDefn GhcPs
|
|
-> ToBriDocM BriDocNumbered
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext
|
|
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
|
|
#else
|
|
layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of
|
|
#endif
|
|
-- newtype MyType a b = MyType ..
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
|
|
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->
|
|
#else
|
|
HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
|
|
(L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) ->
|
|
#endif
|
|
docWrapNode ltycl $ do
|
|
nameStr <- lrdrNameToTextAnn name
|
|
consNameStr <- lrdrNameToTextAnn consName
|
|
tyVarLine <- fmap return $ createBndrDoc bndrs
|
|
-- headDoc <- fmap return $ docSeq
|
|
-- [ appSep $ docLit (Text.pack "newtype")
|
|
-- , appSep $ docLit nameStr
|
|
-- , appSep tyVarLine
|
|
-- ]
|
|
rhsDoc <- fmap return $ createDetailsDoc consNameStr details
|
|
createDerivingPar mDerivs $ docSeq
|
|
[ appSep $ docLit (Text.pack "newtype")
|
|
, appSep $ docLit nameStr
|
|
, appSep tyVarLine
|
|
, docSeparator
|
|
, docLit (Text.pack "=")
|
|
, docSeparator
|
|
, rhsDoc
|
|
]
|
|
_ -> briDocByExactNoComment ltycl
|
|
|
|
|
|
-- data MyData a b
|
|
-- (zero constructors)
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
|
|
#else
|
|
HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
|
|
#endif
|
|
docWrapNode ltycl $ do
|
|
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
|
nameStr <- lrdrNameToTextAnn name
|
|
tyVarLine <- fmap return $ createBndrDoc bndrs
|
|
createDerivingPar mDerivs $ docSeq
|
|
[ appSep $ docLit (Text.pack "data")
|
|
, lhsContextDoc
|
|
, appSep $ docLit nameStr
|
|
, appSep tyVarLine
|
|
]
|
|
|
|
-- data MyData = MyData ..
|
|
-- data MyData = MyData { .. }
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
|
|
#else
|
|
HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
|
|
#endif
|
|
case cons of
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) ->
|
|
#else
|
|
(L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) ->
|
|
#endif
|
|
docWrapNode ltycl $ do
|
|
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
|
nameStr <- lrdrNameToTextAnn name
|
|
consNameStr <- lrdrNameToTextAnn consName
|
|
tyVarLine <- fmap return $ createBndrDoc bndrs
|
|
forallDoc <- docSharedWrapper createForallDoc qvars
|
|
rhsContextDoc <- case mRhsContext of
|
|
Nothing -> return docEmpty
|
|
Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt
|
|
rhsDoc <- fmap return $ createDetailsDoc consNameStr details
|
|
createDerivingPar mDerivs $ docSeq
|
|
[ appSep $ docLit (Text.pack "data")
|
|
, lhsContextDoc
|
|
, appSep $ docLit nameStr
|
|
, appSep tyVarLine
|
|
, docSeparator
|
|
, docLit (Text.pack "=")
|
|
, docSeparator
|
|
, forallDoc
|
|
, rhsContextDoc
|
|
, rhsDoc
|
|
]
|
|
_ -> briDocByExactNoComment ltycl
|
|
|
|
_ -> briDocByExactNoComment ltycl
|
|
|
|
createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
|
|
createContextDoc [] = docEmpty
|
|
createContextDoc [t] =
|
|
docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator]
|
|
createContextDoc ts = docSeq
|
|
[ docLit (Text.pack "(")
|
|
, docSeq $ List.intersperse docCommaSep (layoutType <$> ts)
|
|
, docLit (Text.pack ") =>")
|
|
, docSeparator
|
|
]
|
|
|
|
createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered
|
|
createBndrDoc bs = do
|
|
tyVarDocs <- bs `forM` \case
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
(L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
|
|
(L _ (KindedTyVar _ext lrdrName kind)) -> do
|
|
#else
|
|
(L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)
|
|
(L _ (KindedTyVar lrdrName kind)) -> do
|
|
#endif
|
|
d <- docSharedWrapper layoutType kind
|
|
return $ (lrdrNameToText lrdrName, Just $ d)
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
(L _ (XTyVarBndr ext)) -> absurdExt ext
|
|
#endif
|
|
docSeq
|
|
$ List.intersperse docSeparator
|
|
$ tyVarDocs
|
|
<&> \(vname, mKind) -> case mKind of
|
|
Nothing -> docLit vname
|
|
Just kind -> docSeq
|
|
[ docLit (Text.pack "(")
|
|
, docLit vname
|
|
, docSeparator
|
|
, docLit (Text.pack "::")
|
|
, docSeparator
|
|
, kind
|
|
, docLit (Text.pack ")")
|
|
]
|
|
|
|
createDerivingPar
|
|
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
createDerivingPar derivs mainDoc = do
|
|
case derivs of
|
|
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
|
(L _ []) -> docLines [mainDoc]
|
|
(L _ types) ->
|
|
docPar mainDoc
|
|
$ docEnsureIndent BrIndentRegular
|
|
$ docLines
|
|
$ docWrapNode derivs
|
|
$ derivingClauseDoc
|
|
<$> types
|
|
#else
|
|
Nothing -> docLines [mainDoc]
|
|
Just types ->
|
|
docPar mainDoc
|
|
$ docEnsureIndent BrIndentRegular
|
|
$ derivingClauseDoc types
|
|
#endif
|
|
|
|
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
|
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
|
|
#else
|
|
derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered
|
|
#endif
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext
|
|
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
|
|
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
|
derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of
|
|
#else
|
|
derivingClauseDoc types = case types of
|
|
#endif
|
|
(L _ []) -> docSeq []
|
|
(L _ ts) ->
|
|
let
|
|
tsLength = length ts
|
|
whenMoreThan1Type val =
|
|
if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "")
|
|
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
|
(lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
|
|
#else
|
|
(lhsStrategy, rhsStrategy) = (docEmpty, docEmpty)
|
|
#endif
|
|
in
|
|
docSeq
|
|
[ docDeriving
|
|
, docWrapNodePrior types $ lhsStrategy
|
|
, docSeparator
|
|
, whenMoreThan1Type "("
|
|
, docWrapNodeRest types
|
|
$ docSeq
|
|
$ List.intersperse docCommaSep
|
|
$ ts <&> \case
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
HsIB _ t -> layoutType t
|
|
XHsImplicitBndrs x -> absurdExt x
|
|
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
|
HsIB _ t _ -> layoutType t
|
|
#else
|
|
HsIB _ t -> layoutType t
|
|
#endif
|
|
, whenMoreThan1Type ")"
|
|
, rhsStrategy
|
|
]
|
|
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */
|
|
where
|
|
strategyLeftRight = \case
|
|
(L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty)
|
|
(L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty)
|
|
(L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty)
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
lVia@(L _ (ViaStrategy viaTypes) ) ->
|
|
( docEmpty
|
|
, case viaTypes of
|
|
HsIB _ext t -> docSeq
|
|
[ docWrapNode lVia $ docLit $ Text.pack " via"
|
|
, docSeparator
|
|
, layoutType t
|
|
]
|
|
XHsImplicitBndrs ext -> absurdExt ext
|
|
)
|
|
#endif
|
|
#endif
|
|
|
|
docDeriving :: ToBriDocM BriDocNumbered
|
|
docDeriving = docLit $ Text.pack "deriving"
|
|
|
|
createDetailsDoc
|
|
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
|
|
createDetailsDoc consNameStr details = case details of
|
|
PrefixCon args -> docSeq
|
|
[ docLit consNameStr
|
|
, docSeparator
|
|
, docSeq $ List.intersperse docSeparator $ args <&> layoutType
|
|
]
|
|
RecCon (L _ []) -> docEmpty
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq
|
|
#else
|
|
RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> docSeq
|
|
#endif
|
|
[ docLit consNameStr
|
|
, docSeparator
|
|
, docWrapNodePrior lRec $ docLit $ Text.pack "{"
|
|
, docSeparator
|
|
, docWrapNodeRest lRec $ docSeq $ createNamesAndTypeDoc lField names t
|
|
, docSeparator
|
|
, docLit $ Text.pack "}"
|
|
]
|
|
RecCon lRec@(L _ fields@(_:_)) -> do
|
|
let (fDoc1 : fDocR) = mkFieldDocs fields
|
|
docAddBaseY BrIndentRegular $ docPar
|
|
(docLit consNameStr)
|
|
(docWrapNodePrior lRec $ docLines
|
|
[ docCols ColRecDecl
|
|
$ appSep (docLit (Text.pack "{"))
|
|
: fDoc1
|
|
, docWrapNodeRest lRec $ docLines $ fDocR <&> \f ->
|
|
docCols ColRecDecl $ docCommaSep : f
|
|
, docLit $ Text.pack "}"
|
|
]
|
|
)
|
|
InfixCon arg1 arg2 -> docSeq
|
|
[ layoutType arg1
|
|
, docSeparator
|
|
, docLit consNameStr
|
|
, docSeparator
|
|
, layoutType arg2
|
|
]
|
|
where
|
|
mkFieldDocs :: [LConDeclField GhcPs] -> [[ToBriDocM BriDocNumbered]]
|
|
mkFieldDocs = fmap $ \lField -> case lField of
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
|
|
L _ (XConDeclField x) -> absurdExt x
|
|
#else
|
|
L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t
|
|
#endif
|
|
|
|
createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered
|
|
createForallDoc [] = docEmpty
|
|
createForallDoc lhsTyVarBndrs = docSeq
|
|
[ docLit (Text.pack "forall ")
|
|
, createBndrDoc lhsTyVarBndrs
|
|
, docLit (Text.pack " .")
|
|
, docSeparator
|
|
]
|
|
|
|
createNamesAndTypeDoc
|
|
:: Data.Data.Data ast
|
|
=> Located ast
|
|
-> [GenLocated t (FieldOcc GhcPs)]
|
|
-> Located (HsType GhcPs)
|
|
-> [ToBriDocM BriDocNumbered]
|
|
createNamesAndTypeDoc lField names t =
|
|
[ docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
|
|
[ docSeq
|
|
$ List.intersperse docCommaSep
|
|
$ names
|
|
<&> \case
|
|
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
|
L _ (XFieldOcc x) -> absurdExt x
|
|
L _ (FieldOcc _ fieldName) ->
|
|
#else
|
|
L _ (FieldOcc fieldName _) ->
|
|
#endif
|
|
docLit =<< lrdrNameToTextAnn fieldName
|
|
, docSeparator
|
|
]
|
|
, docWrapNodeRest lField $ docSeq
|
|
[ docLit $ Text.pack "::"
|
|
, docSeparator
|
|
, layoutType t
|
|
]
|
|
]
|