Signature.hs

{-# 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 (WithComments Type)
  | Record
      { fields :: WithComments [WithComments RecordField]
      , result :: WithComments Type
      }

instance CommentExtraction ConstructorSignature where
  nodeComments (ByArrows _) = NodeComments [] [] []
  nodeComments Record {} = NodeComments [] [] []

prettyHorizontally :: ConstructorSignature -> Printer ()
prettyHorizontally (ByArrows signature) = pretty signature
prettyHorizontally Record {..} =
  inter
    (string " -> ")
    [prettyWith fields (vFields' . fmap pretty), pretty result]

prettyVertically :: ConstructorSignature -> Printer ()
prettyVertically (ByArrows signature) =
  pretty $ fmap mkVerticalFuncType signature
prettyVertically Record {..} =
  prefixedLined
    "-> "
    [prettyWith fields (vFields' . fmap pretty), pretty result]

mkConstructorSignature :: GHC.ConDecl GHC.GhcPs -> Maybe ConstructorSignature
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT _ xs, ..} =
  Just $ ByArrows (buildFunctionType xs con_res_ty)
#else
mkConstructorSignature GHC.ConDeclGADT {con_g_args = GHC.PrefixConGADT xs, ..} =
  Just $ ByArrows (buildFunctionType xs con_res_ty)
#endif
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
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
        }
#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 {} = Nothing

buildFunctionType ::
     [GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)]
  -> GHC.LHsType GHC.GhcPs
  -> WithComments Type
buildFunctionType scaledTypes resultTy =
  mkType <$> fromGenLocated (foldr mkFun resultTy scaledTypes)

mkFun ::
     GHC.HsScaled GHC.GhcPs (GHC.LHsType GHC.GhcPs)
  -> GHC.LHsType GHC.GhcPs
  -> GHC.LHsType GHC.GhcPs
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
mkFun (GHC.HsScaled mult paramTy) accTy =
  GHC.noLocA (GHC.HsFunTy GHC.noExtField mult paramTy accTy)
#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)
mkFun (GHC.HsScaled mult paramTy) accTy =
  GHC.noLocA (GHC.HsFunTy GHC.noAnn mult paramTy accTy)
#else
mkFun (GHC.HsScaled mult paramTy) accTy =
  GHC.noLocA (GHC.HsFunTy GHC.NoExtField mult paramTy accTy)
#endif