{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

module HIndent.Ast.Declaration.Data.GADT.Constructor
  ( GADTConstructor
  , mkGADTConstructor
  ) where

import Data.Maybe
import qualified GHC.Types.SrcLoc as GHC
import HIndent.Ast.Context
import HIndent.Ast.Declaration.Data.GADT.Constructor.Signature
import HIndent.Ast.Name.Prefix
import HIndent.Ast.NodeComments
import HIndent.Ast.Type.Variable
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments
#if MIN_VERSION_ghc_lib_parser(9, 6, 0)
import qualified Data.List.NonEmpty as NE
#endif
data GADTConstructor = GADTConstructor
  { GADTConstructor -> [WithComments PrefixName]
names :: [WithComments PrefixName]
  , GADTConstructor -> Maybe (WithComments [WithComments TypeVariable])
bindings :: Maybe (WithComments [WithComments TypeVariable])
  , GADTConstructor -> Maybe (WithComments Context)
context :: Maybe (WithComments Context)
  , GADTConstructor -> ConstructorSignature
signature :: ConstructorSignature
  }

instance CommentExtraction GADTConstructor where
  nodeComments :: GADTConstructor -> NodeComments
nodeComments GADTConstructor {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

instance Pretty GADTConstructor where
  pretty' :: GADTConstructor -> Printer ()
pretty' (GADTConstructor {[WithComments PrefixName]
Maybe (WithComments [WithComments TypeVariable])
Maybe (WithComments Context)
ConstructorSignature
names :: GADTConstructor -> [WithComments PrefixName]
bindings :: GADTConstructor -> Maybe (WithComments [WithComments TypeVariable])
context :: GADTConstructor -> Maybe (WithComments Context)
signature :: GADTConstructor -> ConstructorSignature
names :: [WithComments PrefixName]
bindings :: Maybe (WithComments [WithComments TypeVariable])
context :: Maybe (WithComments Context)
signature :: ConstructorSignature
..}) = do
    [Printer ()] -> Printer ()
hCommaSep ([Printer ()] -> Printer ()) -> [Printer ()] -> Printer ()
forall a b. (a -> b) -> a -> b
$ (WithComments PrefixName -> Printer ())
-> [WithComments PrefixName] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WithComments PrefixName -> (PrefixName -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
`prettyWith` PrefixName -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty) [WithComments PrefixName]
names
    Printer ()
hor Printer () -> Printer () -> Printer ()
forall a. Printer a -> Printer a -> Printer a
<-|> Printer ()
ver
    where
      hor :: Printer ()
hor = HasCallStack => String -> Printer ()
String -> Printer ()
string String
" :: " Printer () -> Printer () -> Printer ()
forall a. Printer () -> Printer a -> Printer a
|=> Printer ()
body
      ver :: Printer ()
ver = Printer ()
newline Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Printer () -> Printer ()
forall a. Printer a -> Printer a
indentedBlock (HasCallStack => String -> Printer ()
String -> Printer ()
string String
":: " Printer () -> Printer () -> Printer ()
forall a. Printer () -> Printer a -> Printer a
|=> Printer ()
body)
      body :: Printer ()
body =
        case (Maybe (WithComments [WithComments TypeVariable])
bindings, Maybe (WithComments Context)
context) of
          (Just WithComments [WithComments TypeVariable]
bs, Just WithComments Context
ctx) -> WithComments [WithComments TypeVariable]
-> WithComments Context -> Printer ()
forall {a} {a}.
(Pretty a, Pretty a) =>
WithComments [a] -> a -> Printer ()
withForallCtx WithComments [WithComments TypeVariable]
bs WithComments Context
ctx
          (Just WithComments [WithComments TypeVariable]
bs, Maybe (WithComments Context)
Nothing) -> WithComments [WithComments TypeVariable] -> Printer ()
forall {a}. Pretty a => WithComments [a] -> Printer ()
withForallOnly WithComments [WithComments TypeVariable]
bs
          (Maybe (WithComments [WithComments TypeVariable])
Nothing, Just WithComments Context
ctx) -> WithComments Context -> Printer ()
forall a. Pretty a => a -> Printer ()
withCtxOnly WithComments Context
ctx
          (Maybe (WithComments [WithComments TypeVariable])
Nothing, Maybe (WithComments Context)
Nothing) -> Printer ()
noForallCtx
      withForallCtx :: WithComments [a] -> a -> Printer ()
withForallCtx WithComments [a]
bs a
ctx = do
        HasCallStack => String -> Printer ()
String -> Printer ()
string String
"forall"
        WithComments [a] -> ([a] -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
prettyWith WithComments [a]
bs ([Printer ()] -> Printer ()
spacePrefixed ([Printer ()] -> Printer ())
-> ([a] -> [Printer ()]) -> [a] -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Printer ()) -> [a] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty)
        Printer ()
dot
        (Printer ()
space Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty a
ctx) Printer () -> Printer () -> Printer ()
forall a. Printer a -> Printer a -> Printer a
<-|> (Printer ()
newline Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty a
ctx)
        Printer ()
newline
        String -> Printer () -> Printer ()
prefixed String
"=> " (Printer () -> Printer ()) -> Printer () -> Printer ()
forall a b. (a -> b) -> a -> b
$ ConstructorSignature -> Printer ()
prettyVertically ConstructorSignature
signature
      withForallOnly :: WithComments [a] -> Printer ()
withForallOnly WithComments [a]
bs = do
        HasCallStack => String -> Printer ()
String -> Printer ()
string String
"forall"
        WithComments [a] -> ([a] -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
prettyWith WithComments [a]
bs ([Printer ()] -> Printer ()
spacePrefixed ([Printer ()] -> Printer ())
-> ([a] -> [Printer ()]) -> [a] -> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Printer ()) -> [a] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty)
        Printer ()
dot
        (Printer ()
space Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConstructorSignature -> Printer ()
prettyHorizontally ConstructorSignature
signature)
          Printer () -> Printer () -> Printer ()
forall a. Printer a -> Printer a -> Printer a
<-|> (Printer ()
newline Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConstructorSignature -> Printer ()
prettyVertically ConstructorSignature
signature)
      withCtxOnly :: a -> Printer ()
withCtxOnly a
ctx =
        (a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty a
ctx Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => String -> Printer ()
String -> Printer ()
string String
" => " Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConstructorSignature -> Printer ()
prettyHorizontally ConstructorSignature
signature)
          Printer () -> Printer () -> Printer ()
forall a. Printer a -> Printer a -> Printer a
<-|> (a -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty a
ctx Printer () -> Printer () -> Printer ()
forall a b. Printer a -> Printer b -> Printer b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Printer () -> Printer ()
prefixed String
"=> " (ConstructorSignature -> Printer ()
prettyVertically ConstructorSignature
signature))
      noForallCtx :: Printer ()
noForallCtx = ConstructorSignature -> Printer ()
prettyHorizontally ConstructorSignature
signature Printer () -> Printer () -> Printer ()
forall a. Printer a -> Printer a -> Printer a
<-|> ConstructorSignature -> Printer ()
prettyVertically ConstructorSignature
signature

mkGADTConstructor :: GHC.ConDecl GHC.GhcPs -> Maybe GADTConstructor
mkGADTConstructor :: ConDecl GhcPs -> Maybe GADTConstructor
mkGADTConstructor decl :: ConDecl GhcPs
decl@GHC.ConDeclGADT {Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LHsType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
HsConDeclGADTDetails GhcPs
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_res_ty :: LHsType GhcPs
con_doc :: Maybe (LHsDoc GhcPs)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
..} = GADTConstructor -> Maybe GADTConstructor
forall a. a -> Maybe a
Just (GADTConstructor -> Maybe GADTConstructor)
-> GADTConstructor -> Maybe GADTConstructor
forall a b. (a -> b) -> a -> b
$ GADTConstructor {[WithComments PrefixName]
Maybe (WithComments [WithComments TypeVariable])
Maybe (WithComments Context)
ConstructorSignature
names :: [WithComments PrefixName]
bindings :: Maybe (WithComments [WithComments TypeVariable])
context :: Maybe (WithComments Context)
signature :: ConstructorSignature
names :: [WithComments PrefixName]
bindings :: Maybe (WithComments [WithComments TypeVariable])
signature :: ConstructorSignature
context :: Maybe (WithComments Context)
..}
  where
    names :: [WithComments PrefixName]
names = [WithComments PrefixName]
-> Maybe [WithComments PrefixName] -> [WithComments PrefixName]
forall a. a -> Maybe a -> a
fromMaybe (String -> [WithComments PrefixName]
forall a. HasCallStack => String -> a
error String
"Couldn't get names.") (Maybe [WithComments PrefixName] -> [WithComments PrefixName])
-> Maybe [WithComments PrefixName] -> [WithComments PrefixName]
forall a b. (a -> b) -> a -> b
$ ConDecl GhcPs -> Maybe [WithComments PrefixName]
getNames ConDecl GhcPs
decl
    bindings :: Maybe (WithComments [WithComments TypeVariable])
bindings =
      case XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_bndrs of
        GHC.L SrcSpanAnnA
_ GHC.HsOuterImplicit {} -> Maybe (WithComments [WithComments TypeVariable])
forall a. Maybe a
Nothing
        GHC.L SrcSpanAnnA
l GHC.HsOuterExplicit {[LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
XHsOuterExplicit GhcPs Specificity
hso_xexplicit :: XHsOuterExplicit GhcPs Specificity
hso_bndrs :: [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
hso_bndrs :: forall flag pass.
HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]
hso_xexplicit :: forall flag pass.
HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag
..} ->
          WithComments [WithComments TypeVariable]
-> Maybe (WithComments [WithComments TypeVariable])
forall a. a -> Maybe a
Just
            (WithComments [WithComments TypeVariable]
 -> Maybe (WithComments [WithComments TypeVariable]))
-> WithComments [WithComments TypeVariable]
-> Maybe (WithComments [WithComments TypeVariable])
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA [WithComments TypeVariable]
-> WithComments [WithComments TypeVariable]
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated
            (GenLocated SrcSpanAnnA [WithComments TypeVariable]
 -> WithComments [WithComments TypeVariable])
-> GenLocated SrcSpanAnnA [WithComments TypeVariable]
-> WithComments [WithComments TypeVariable]
forall a b. (a -> b) -> a -> b
$ ([GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
 -> [WithComments TypeVariable])
-> GenLocated
     SrcSpanAnnA
     [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> GenLocated SrcSpanAnnA [WithComments TypeVariable]
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ((GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
 -> WithComments TypeVariable)
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> [WithComments TypeVariable]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsTyVarBndr Specificity GhcPs -> TypeVariable)
-> WithComments (HsTyVarBndr Specificity GhcPs)
-> WithComments TypeVariable
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsTyVarBndr Specificity GhcPs -> TypeVariable
forall a. HsTyVarBndr a GhcPs -> TypeVariable
mkTypeVariable (WithComments (HsTyVarBndr Specificity GhcPs)
 -> WithComments TypeVariable)
-> (GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
    -> WithComments (HsTyVarBndr Specificity GhcPs))
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
-> WithComments TypeVariable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
-> WithComments (HsTyVarBndr Specificity GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated))
                (SrcSpanAnnA
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
-> GenLocated
     SrcSpanAnnA
     [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall l e. l -> e -> GenLocated l e
GHC.L SrcSpanAnnA
l [LHsTyVarBndr Specificity (NoGhcTc GhcPs)]
[GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
hso_bndrs)
    signature :: ConstructorSignature
signature =
      ConstructorSignature
-> Maybe ConstructorSignature -> ConstructorSignature
forall a. a -> Maybe a -> a
fromMaybe (String -> ConstructorSignature
forall a. HasCallStack => String -> a
error String
"Couldn't get signature.") (Maybe ConstructorSignature -> ConstructorSignature)
-> Maybe ConstructorSignature -> ConstructorSignature
forall a b. (a -> b) -> a -> b
$ ConDecl GhcPs -> Maybe ConstructorSignature
mkConstructorSignature ConDecl GhcPs
decl
    context :: Maybe (WithComments Context)
context = (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
 -> WithComments Context)
-> Maybe
     (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> Maybe (WithComments Context)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([GenLocated SrcSpanAnnA (HsType GhcPs)] -> Context)
-> WithComments [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> WithComments Context
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsContext GhcPs -> Context
[GenLocated SrcSpanAnnA (HsType GhcPs)] -> Context
mkContext (WithComments [GenLocated SrcSpanAnnA (HsType GhcPs)]
 -> WithComments Context)
-> (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
    -> WithComments [GenLocated SrcSpanAnnA (HsType GhcPs)])
-> GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> WithComments Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)]
-> WithComments [GenLocated SrcSpanAnnA (HsType GhcPs)]
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated) Maybe (LHsContext GhcPs)
Maybe
  (GenLocated SrcSpanAnnC [GenLocated SrcSpanAnnA (HsType GhcPs)])
con_mb_cxt
mkGADTConstructor ConDecl GhcPs
_ = Maybe GADTConstructor
forall a. Maybe a
Nothing

getNames :: GHC.ConDecl GHC.GhcPs -> Maybe [WithComments PrefixName]
#if MIN_VERSION_ghc_lib_parser(9, 6, 0)
getNames :: ConDecl GhcPs -> Maybe [WithComments PrefixName]
getNames GHC.ConDeclGADT {Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LHsType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
HsConDeclGADTDetails GhcPs
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_res_ty :: forall pass. ConDecl pass -> LHsType pass
con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_bndrs :: forall pass. ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)
con_names :: forall pass. ConDecl pass -> NonEmpty (LIdP pass)
con_g_ext :: forall pass. ConDecl pass -> XConDeclGADT pass
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_g_args :: HsConDeclGADTDetails GhcPs
con_res_ty :: LHsType GhcPs
con_doc :: Maybe (LHsDoc GhcPs)
..} =
  [WithComments PrefixName] -> Maybe [WithComments PrefixName]
forall a. a -> Maybe a
Just ([WithComments PrefixName] -> Maybe [WithComments PrefixName])
-> [WithComments PrefixName] -> Maybe [WithComments PrefixName]
forall a b. (a -> b) -> a -> b
$ NonEmpty (WithComments PrefixName) -> [WithComments PrefixName]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (WithComments PrefixName) -> [WithComments PrefixName])
-> NonEmpty (WithComments PrefixName) -> [WithComments PrefixName]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnN RdrName -> WithComments PrefixName)
-> NonEmpty (GenLocated SrcSpanAnnN RdrName)
-> NonEmpty (WithComments PrefixName)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (GenLocated SrcSpanAnnN PrefixName -> WithComments PrefixName
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated (GenLocated SrcSpanAnnN PrefixName -> WithComments PrefixName)
-> (GenLocated SrcSpanAnnN RdrName
    -> GenLocated SrcSpanAnnN PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> WithComments PrefixName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RdrName -> PrefixName)
-> GenLocated SrcSpanAnnN RdrName
-> GenLocated SrcSpanAnnN PrefixName
forall a b.
(a -> b) -> GenLocated SrcSpanAnnN a -> GenLocated SrcSpanAnnN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RdrName -> PrefixName
mkPrefixName) NonEmpty (LIdP GhcPs)
NonEmpty (GenLocated SrcSpanAnnN RdrName)
con_names
#else
getNames GHC.ConDeclGADT {..} =
  Just $ fmap (fromGenLocated . fmap mkPrefixName) con_names
#endif
getNames ConDecl GhcPs
_ = Maybe [WithComments PrefixName]
forall a. Maybe a
Nothing