hindent-6.3.0: src/HIndent/Ast/Declaration/Signature.hs

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

module HIndent.Ast.Declaration.Signature
  ( Signature
  , mkSignature
  ) where

import qualified GHC.Types.Basic as GHC
import HIndent.Applicative
import HIndent.Ast.Declaration.Signature.BooleanFormula
import HIndent.Ast.Declaration.Signature.Fixity
import HIndent.Ast.Declaration.Signature.Inline.Phase
import HIndent.Ast.Declaration.Signature.Inline.Spec
import HIndent.Ast.Name.Infix
import HIndent.Ast.Name.Prefix
import HIndent.Ast.NodeComments
import HIndent.Ast.Type (DeclSigType, Type, mkDeclSigType, mkTypeFromHsSigType)
import HIndent.Ast.WithComments
import qualified HIndent.GhcLibParserWrapper.GHC.Hs as GHC
import {-# SOURCE #-} HIndent.Pretty
import HIndent.Pretty.Combinators
import HIndent.Pretty.NodeComments

-- We want to use the same name for `parameters` and `signature`, but GHC
-- doesn't allow it.
data Signature
  = Type
      { names :: [WithComments PrefixName]
      , parameters :: WithComments DeclSigType
      }
  | Pattern
      { names :: [WithComments PrefixName]
      , signature :: WithComments Type
      }
  | DefaultClassMethod
      { names :: [WithComments PrefixName]
      , methodSig :: WithComments DeclSigType
      }
  | ClassMethod
      { names :: [WithComments PrefixName]
      , methodSig :: WithComments DeclSigType
      }
  | Fixity
      { opNames :: [WithComments InfixName] -- Using `names` causes a type conflict.
      , fixity :: Fixity
      }
  | Inline
      { name :: WithComments PrefixName
      , spec :: InlineSpec
      , phase :: Maybe InlinePhase
      }
  | Specialise
      { name :: WithComments PrefixName
      , sigs :: [WithComments Type]
      }
  | SpecialiseInstance (WithComments Type)
  | Minimal (WithComments BooleanFormula)
  | Scc (WithComments PrefixName)
  | Complete (WithComments [WithComments PrefixName])

instance CommentExtraction Signature where
  nodeComments Type {} = NodeComments [] [] []
  nodeComments Pattern {} = NodeComments [] [] []
  nodeComments DefaultClassMethod {} = NodeComments [] [] []
  nodeComments ClassMethod {} = NodeComments [] [] []
  nodeComments Fixity {} = NodeComments [] [] []
  nodeComments Inline {} = NodeComments [] [] []
  nodeComments Specialise {} = NodeComments [] [] []
  nodeComments SpecialiseInstance {} = NodeComments [] [] []
  nodeComments Minimal {} = NodeComments [] [] []
  nodeComments Scc {} = NodeComments [] [] []
  nodeComments Complete {} = NodeComments [] [] []

instance Pretty Signature where
  pretty' Type {..} = do
    printFunName
    string " ::"
    horizontal <-|> vertical
    where
      horizontal = do
        space
        pretty parameters
      vertical = do
        headLen <- printerLength printFunName
        indentSpaces <- getIndentSpaces
        if headLen < indentSpaces
          then space |=> pretty parameters
          else do
            newline
            indentedBlock $ indentedWithSpace 3 $ pretty parameters
      printFunName = hCommaSep $ fmap pretty names
  pretty' Pattern {..} =
    spaced
      [ string "pattern"
      , hCommaSep $ fmap pretty names
      , string "::"
      , pretty signature
      ]
  pretty' DefaultClassMethod {..} = do
    string "default "
    hCommaSep $ fmap pretty names
    string " ::"
    hor <-|> ver
    where
      hor = space >> pretty methodSig
      ver = do
        newline
        indentedBlock $ indentedWithSpace 3 $ pretty methodSig
  pretty' ClassMethod {..} = do
    hCommaSep $ fmap pretty names
    string " ::"
    hor <-|> ver
    where
      hor = space >> pretty methodSig
      ver = do
        newline
        indentedBlock $ indentedWithSpace 3 $ pretty methodSig
  pretty' Fixity {..} = spaced [pretty fixity, hCommaSep $ fmap pretty opNames]
  pretty' Inline {..} = do
    string "{-# "
    pretty spec
    whenJust phase $ \x -> space >> pretty x
    space
    pretty name
    string " #-}"
  pretty' Specialise {..} =
    spaced
      [ string "{-# SPECIALISE"
      , pretty name
      , string "::"
      , hCommaSep $ fmap pretty sigs
      , string "#-}"
      ]
  pretty' (SpecialiseInstance sig) =
    spaced [string "{-# SPECIALISE instance", pretty sig, string "#-}"]
  pretty' (Minimal xs) =
    string "{-# MINIMAL " |=> do
      pretty xs
      string " #-}"
  pretty' (Scc name) = spaced [string "{-# SCC", pretty name, string "#-}"]
  pretty' (Complete names) =
    spaced
      [ string "{-# COMPLETE"
      , prettyWith names (hCommaSep . fmap pretty)
      , string "#-}"
      ]

mkSignature :: GHC.Sig GHC.GhcPs -> Signature
mkSignature (GHC.TypeSig _ ns GHC.HsWC { hswc_ext = GHC.NoExtField
                                       , GHC.hswc_body = params
                                       }) = Type {..}
  where
    names = fmap (fromGenLocated . fmap mkPrefixName) ns
    parameters = flattenComments $ mkDeclSigType <$> fromGenLocated params
mkSignature (GHC.PatSynSig _ ns s) = Pattern {..}
  where
    names = fmap (fromGenLocated . fmap mkPrefixName) ns
    signature = flattenComments $ mkTypeFromHsSigType <$> fromGenLocated s
mkSignature (GHC.ClassOpSig _ True ns s) = DefaultClassMethod {..}
  where
    names = fmap (fromGenLocated . fmap mkPrefixName) ns
    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s
mkSignature (GHC.ClassOpSig _ False ns s) = ClassMethod {..}
  where
    names = fmap (fromGenLocated . fmap mkPrefixName) ns
    methodSig = flattenComments $ mkDeclSigType <$> fromGenLocated s
mkSignature (GHC.FixSig _ (GHC.FixitySig _ ops fy)) = Fixity {..}
  where
    fixity = mkFixity fy
    opNames = fmap (fromGenLocated . fmap mkInfixName) ops
mkSignature (GHC.InlineSig _ n GHC.InlinePragma {..}) = Inline {..}
  where
    name = fromGenLocated $ fmap mkPrefixName n
    spec = mkInlineSpec inl_inline
    phase = mkInlinePhase inl_act
mkSignature (GHC.SpecSig _ n s _) = Specialise {..}
  where
    name = fromGenLocated $ fmap mkPrefixName n
    sigs = flattenComments . fmap mkTypeFromHsSigType . fromGenLocated <$> s
#if MIN_VERSION_ghc_lib_parser(9, 10, 1)
mkSignature (GHC.SCCFunSig _ n _) = Scc name
  where
    name = fromGenLocated $ fmap mkPrefixName n
mkSignature (GHC.CompleteMatchSig _ ns _) = Complete names
  where
    names = mkWithComments $ fmap (fromGenLocated . fmap mkPrefixName) ns
#elif MIN_VERSION_ghc_lib_parser(9, 6, 0)
mkSignature (GHC.SCCFunSig _ n _) = Scc name
  where
    name = fromGenLocated $ fmap mkPrefixName n
mkSignature (GHC.CompleteMatchSig _ ns _) = Complete names
  where
    names = fromGenLocated $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) ns
#elif MIN_VERSION_ghc_lib_parser(9, 4, 0)
mkSignature (GHC.SCCFunSig _ _ name _) =
  Scc $ fromGenLocated $ fmap mkPrefixName name
mkSignature (GHC.CompleteMatchSig _ _ names _) =
  Complete
    $ fromGenLocated
    $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) names
#else
mkSignature (GHC.SCCFunSig _ _ name _) =
  Scc $ fromGenLocated $ fmap mkPrefixName name
mkSignature (GHC.CompleteMatchSig _ _ names _) =
  Complete
    $ fromGenLocated
    $ fmap (fmap (fromGenLocated . fmap mkPrefixName)) names
#endif
#if MIN_VERSION_ghc_lib_parser(9, 6, 0)
mkSignature (GHC.SpecInstSig _ sig) =
  SpecialiseInstance
    $ flattenComments
    $ mkTypeFromHsSigType <$> fromGenLocated sig
mkSignature (GHC.MinimalSig _ xs) =
  Minimal $ mkBooleanFormula <$> fromGenLocated xs
#else
mkSignature (GHC.SpecInstSig _ _ sig) = SpecialiseInstance sig
mkSignature (GHC.MinimalSig _ _ xs) =
  Minimal $ mkBooleanFormula <$> fromGenLocated xs
mkSignature GHC.IdSig {} =
  error "`ghc-lib-parser` never generates this AST node."
#endif