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

module HIndent.Ast.Declaration.Data.GADT.Constructor.Signature
  ( ConstructorSignature
  , mkConstructorSignature
  , prettyHorizontally
  , prettyVertically
  ) where

import HIndent.Ast.Declaration.Data.Record.Field
import HIndent.Ast.NodeComments
import HIndent.Ast.Type
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments
import HIndent.Printer

data ConstructorSignature
  = ByArrows
      { ConstructorSignature -> [WithComments Type]
parameters :: [WithComments Type]
      , ConstructorSignature -> WithComments Type
result :: WithComments Type
      }
  | Record
      { ConstructorSignature -> WithComments [WithComments RecordField]
fields :: WithComments [WithComments RecordField]
      , result :: WithComments Type
      }

instance CommentExtraction ConstructorSignature where
  nodeComments :: ConstructorSignature -> NodeComments
nodeComments ByArrows {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []
  nodeComments Record {} = [LEpaComment] -> [LEpaComment] -> [LEpaComment] -> NodeComments
NodeComments [] [] []

prettyHorizontally :: ConstructorSignature -> Printer ()
prettyHorizontally :: ConstructorSignature -> Printer ()
prettyHorizontally ByArrows {[WithComments Type]
WithComments Type
parameters :: ConstructorSignature -> [WithComments Type]
result :: ConstructorSignature -> WithComments Type
parameters :: [WithComments Type]
result :: WithComments Type
..} =
  Printer () -> [Printer ()] -> Printer ()
inter (HasCallStack => String -> Printer ()
String -> Printer ()
string String
" -> ") ([Printer ()] -> Printer ()) -> [Printer ()] -> Printer ()
forall a b. (a -> b) -> a -> b
$ (WithComments Type -> Printer ())
-> [WithComments Type] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty [WithComments Type]
parameters [Printer ()] -> [Printer ()] -> [Printer ()]
forall a. [a] -> [a] -> [a]
++ [WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Type
result]
prettyHorizontally Record {WithComments [WithComments RecordField]
WithComments Type
result :: ConstructorSignature -> WithComments Type
fields :: ConstructorSignature -> WithComments [WithComments RecordField]
fields :: WithComments [WithComments RecordField]
result :: WithComments Type
..} =
  Printer () -> [Printer ()] -> Printer ()
inter
    (HasCallStack => String -> Printer ()
String -> Printer ()
string String
" -> ")
    [WithComments [WithComments RecordField]
-> ([WithComments RecordField] -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
prettyWith WithComments [WithComments RecordField]
fields ([Printer ()] -> Printer ()
vFields' ([Printer ()] -> Printer ())
-> ([WithComments RecordField] -> [Printer ()])
-> [WithComments RecordField]
-> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithComments RecordField -> Printer ())
-> [WithComments RecordField] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments RecordField -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty), WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Type
result]

prettyVertically :: ConstructorSignature -> Printer ()
prettyVertically :: ConstructorSignature -> Printer ()
prettyVertically ByArrows {[WithComments Type]
WithComments Type
parameters :: ConstructorSignature -> [WithComments Type]
result :: ConstructorSignature -> WithComments Type
parameters :: [WithComments Type]
result :: WithComments Type
..} =
  String -> [Printer ()] -> Printer ()
prefixedLined String
"-> " ([Printer ()] -> Printer ()) -> [Printer ()] -> Printer ()
forall a b. (a -> b) -> a -> b
$ (WithComments Type -> Printer ())
-> [WithComments Type] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty [WithComments Type]
parameters [Printer ()] -> [Printer ()] -> [Printer ()]
forall a. [a] -> [a] -> [a]
++ [WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Type
result]
prettyVertically Record {WithComments [WithComments RecordField]
WithComments Type
result :: ConstructorSignature -> WithComments Type
fields :: ConstructorSignature -> WithComments [WithComments RecordField]
fields :: WithComments [WithComments RecordField]
result :: WithComments Type
..} =
  String -> [Printer ()] -> Printer ()
prefixedLined
    String
"-> "
    [WithComments [WithComments RecordField]
-> ([WithComments RecordField] -> Printer ()) -> Printer ()
forall a. WithComments a -> (a -> Printer ()) -> Printer ()
prettyWith WithComments [WithComments RecordField]
fields ([Printer ()] -> Printer ()
vFields' ([Printer ()] -> Printer ())
-> ([WithComments RecordField] -> [Printer ()])
-> [WithComments RecordField]
-> Printer ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithComments RecordField -> Printer ())
-> [WithComments RecordField] -> [Printer ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithComments RecordField -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty), WithComments Type -> Printer ()
forall a. Pretty a => a -> Printer ()
pretty WithComments Type
result]

mkConstructorSignature :: GHC.ConDecl GHC.GhcPs -> Maybe ConstructorSignature
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
mkConstructorSignature :: ConDecl GhcPs -> Maybe ConstructorSignature
mkConstructorSignature GHC.ConDeclGADT {con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = GHC.PrefixConGADT XPrefixConGADT GhcPs
_ [HsScaled GhcPs (LBangType GhcPs)]
xs, Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LBangType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_g_ext :: XConDeclGADT GhcPs
con_names :: NonEmpty (LIdP GhcPs)
con_bndrs :: XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_mb_cxt :: Maybe (LHsContext GhcPs)
con_res_ty :: LBangType 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_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
..} =
  ConstructorSignature -> Maybe ConstructorSignature
forall a. a -> Maybe a
Just
    (ConstructorSignature -> Maybe ConstructorSignature)
-> ConstructorSignature -> Maybe ConstructorSignature
forall a b. (a -> b) -> a -> b
$ ByArrows
        { parameters :: [WithComments Type]
parameters =
            (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
 -> WithComments Type)
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [WithComments Type]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsType GhcPs -> Type)
-> WithComments (HsType GhcPs) -> WithComments Type
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsType GhcPs -> Type
mkType (WithComments (HsType GhcPs) -> WithComments Type)
-> (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
    -> WithComments (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> WithComments Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsType GhcPs)
-> WithComments (HsType GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> WithComments (HsType GhcPs))
-> (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
    -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> WithComments (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall pass a. HsScaled pass a -> a
GHC.hsScaledThing) [HsScaled GhcPs (LBangType GhcPs)]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
xs
        , result :: WithComments Type
result = HsType GhcPs -> Type
mkType (HsType GhcPs -> Type)
-> WithComments (HsType GhcPs) -> WithComments Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsType GhcPs)
-> WithComments (HsType GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated LBangType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
con_res_ty
        }
#else
mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT xs, ..} =
  Just
    $ ByArrows
        { parameters =
            fmap (fmap mkType . fromGenLocated . GHC.hsScaledThing) xs
        , result = mkType <$> fromGenLocated con_res_ty
        }
#endif
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
mkConstructorSignature GHC.ConDeclGADT {con_g_args :: forall pass. ConDecl pass -> HsConDeclGADTDetails pass
con_g_args = GHC.RecConGADT XRecConGADT GhcPs
_ XRec GhcPs [LConDeclField GhcPs]
xs, Maybe (LHsContext GhcPs)
Maybe (LHsDoc GhcPs)
NonEmpty (LIdP GhcPs)
XConDeclGADT GhcPs
LBangType GhcPs
XRec GhcPs (HsOuterSigTyVarBndrs GhcPs)
con_doc :: forall pass. ConDecl pass -> Maybe (LHsDoc pass)
con_res_ty :: forall pass. ConDecl pass -> LHsType 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_res_ty :: LBangType GhcPs
con_doc :: Maybe (LHsDoc GhcPs)
..} =
  ConstructorSignature -> Maybe ConstructorSignature
forall a. a -> Maybe a
Just
    (ConstructorSignature -> Maybe ConstructorSignature)
-> ConstructorSignature -> Maybe ConstructorSignature
forall a b. (a -> b) -> a -> b
$ Record
        { fields :: WithComments [WithComments RecordField]
fields =
            GenLocated SrcSpanAnnL [WithComments RecordField]
-> WithComments [WithComments RecordField]
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated
              (GenLocated SrcSpanAnnL [WithComments RecordField]
 -> WithComments [WithComments RecordField])
-> GenLocated SrcSpanAnnL [WithComments RecordField]
-> WithComments [WithComments RecordField]
forall a b. (a -> b) -> a -> b
$ ([GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
 -> [WithComments RecordField])
-> GenLocated
     SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated SrcSpanAnnL [WithComments RecordField]
forall a b.
(a -> b) -> GenLocated SrcSpanAnnL a -> GenLocated SrcSpanAnnL b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated SrcSpanAnnA (ConDeclField GhcPs)
 -> WithComments RecordField)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [WithComments RecordField]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ConDeclField GhcPs -> RecordField)
-> WithComments (ConDeclField GhcPs) -> WithComments RecordField
forall a b. (a -> b) -> WithComments a -> WithComments b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConDeclField GhcPs -> RecordField
mkRecordField (WithComments (ConDeclField GhcPs) -> WithComments RecordField)
-> (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
    -> WithComments (ConDeclField GhcPs))
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> WithComments RecordField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> WithComments (ConDeclField GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated)) XRec GhcPs [LConDeclField GhcPs]
GenLocated
  SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
xs
        , result :: WithComments Type
result = HsType GhcPs -> Type
mkType (HsType GhcPs -> Type)
-> WithComments (HsType GhcPs) -> WithComments Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnA (HsType GhcPs)
-> WithComments (HsType GhcPs)
forall l a. CommentExtraction l => GenLocated l a -> WithComments a
fromGenLocated LBangType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
con_res_ty
        }
#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)
mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs _, ..} =
  Just
    $ Record
        { fields =
            fromGenLocated
              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs
        , result = mkType <$> fromGenLocated con_res_ty
        }
#else
mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.RecConGADT xs, ..} =
  Just
    $ Record
        { fields =
            fromGenLocated
              $ fmap (fmap (fmap mkRecordField . fromGenLocated)) xs
        , result = mkType <$> fromGenLocated con_res_ty
        }
#endif
mkConstructorSignature GHC.ConDeclH98 {} = Maybe ConstructorSignature
forall a. Maybe a
Nothing