{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Type signature declarations.
module Ormolu.Printer.Meat.Declaration.Signature
  ( p_sigDecl,
    p_typeAscription,
    p_activation,
    p_standaloneKindSig,
  )
where

import Control.Monad
import GHC.Data.BooleanFormula
import GHC.Hs
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import Ormolu.Printer.Combinators
import Ormolu.Printer.Meat.Common
import Ormolu.Printer.Meat.Type
import Ormolu.Utils

p_sigDecl :: Sig GhcPs -> R ()
p_sigDecl :: Sig GhcPs -> R ()
p_sigDecl = \case
  TypeSig XTypeSig GhcPs
_ [LIdP GhcPs]
names LHsSigWcType GhcPs
hswc -> Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_typeSig Bool
True [LIdP GhcPs]
names (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType GhcPs
hswc)
  PatSynSig XPatSynSig GhcPs
_ [LIdP GhcPs]
names LHsSigType GhcPs
sigType -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_patSynSig [LIdP GhcPs]
names LHsSigType GhcPs
sigType
  ClassOpSig XClassOpSig GhcPs
_ Bool
def [LIdP GhcPs]
names LHsSigType GhcPs
sigType -> Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_classOpSig Bool
def [LIdP GhcPs]
names LHsSigType GhcPs
sigType
  FixSig XFixSig GhcPs
_ FixitySig GhcPs
sig -> FixitySig GhcPs -> R ()
p_fixSig FixitySig GhcPs
sig
  InlineSig XInlineSig GhcPs
_ LIdP GhcPs
name InlinePragma
inlinePragma -> LocatedN RdrName -> InlinePragma -> R ()
p_inlineSig LIdP GhcPs
name InlinePragma
inlinePragma
  SpecSig XSpecSig GhcPs
_ LIdP GhcPs
name [LHsSigType GhcPs]
ts InlinePragma
inlinePragma -> LocatedN RdrName -> [LHsSigType GhcPs] -> InlinePragma -> R ()
p_specSig LIdP GhcPs
name [LHsSigType GhcPs]
ts InlinePragma
inlinePragma
  SpecInstSig XSpecInstSig GhcPs
_ SourceText
_ LHsSigType GhcPs
sigType -> LHsSigType GhcPs -> R ()
p_specInstSig LHsSigType GhcPs
sigType
  MinimalSig XMinimalSig GhcPs
_ SourceText
_ LBooleanFormula (LIdP GhcPs)
booleanFormula -> LBooleanFormula (LocatedN RdrName) -> R ()
p_minimalSig LBooleanFormula (LIdP GhcPs)
booleanFormula
  CompleteMatchSig XCompleteMatchSig GhcPs
_ SourceText
_sourceText XRec GhcPs [LIdP GhcPs]
cs Maybe (LIdP GhcPs)
ty -> Located [LocatedN RdrName] -> Maybe (LocatedN RdrName) -> R ()
p_completeSig XRec GhcPs [LIdP GhcPs]
cs Maybe (LIdP GhcPs)
ty
  SCCFunSig XSCCFunSig GhcPs
_ SourceText
_ LIdP GhcPs
name Maybe (XRec GhcPs StringLiteral)
literal -> LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R ()
p_sccSig LIdP GhcPs
name Maybe (XRec GhcPs StringLiteral)
literal
  Sig GhcPs
_ -> forall a. String -> a
notImplemented String
"certain types of signature declarations"

p_typeSig ::
  -- | Should the tail of the names be indented
  Bool ->
  -- | Names (before @::@)
  [LocatedN RdrName] ->
  -- | Type
  LHsSigType GhcPs ->
  R ()
p_typeSig :: Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_typeSig Bool
_ [] LHsSigType GhcPs
_ = forall (m :: * -> *) a. Monad m => a -> m a
return () -- should not happen though
p_typeSig Bool
indentTail (LocatedN RdrName
n : [LocatedN RdrName]
ns) LHsSigType GhcPs
sigType = do
  LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
n
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedN RdrName]
ns
    then LHsSigType GhcPs -> R ()
p_typeAscription LHsSigType GhcPs
sigType
    else Bool -> R () -> R ()
inciIf Bool
indentTail forall a b. (a -> b) -> a -> b
$ do
      R ()
commaDel
      forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel LocatedN RdrName -> R ()
p_rdrName [LocatedN RdrName]
ns
      LHsSigType GhcPs -> R ()
p_typeAscription LHsSigType GhcPs
sigType

p_typeAscription ::
  LHsSigType GhcPs ->
  R ()
p_typeAscription :: LHsSigType GhcPs -> R ()
p_typeAscription LHsSigType GhcPs
lsigType =
  R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ forall l a.
HasSrcSpan l =>
GenLocated l a -> (a -> HsType GhcPs) -> (a -> R ()) -> R ()
startTypeAnnotationDecl LHsSigType GhcPs
lsigType (forall l e. GenLocated l e -> e
unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. HsSigType pass -> LHsType pass
sig_body) HsSigType GhcPs -> R ()
p_hsSigType

p_patSynSig ::
  [LocatedN RdrName] ->
  LHsSigType GhcPs ->
  R ()
p_patSynSig :: [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_patSynSig [LocatedN RdrName]
names LHsSigType GhcPs
sigType = do
  Text -> R ()
txt Text
"pattern"
  let body :: R ()
body = Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_typeSig Bool
False [LocatedN RdrName]
names LHsSigType GhcPs
sigType
  if forall (t :: * -> *) a. Foldable t => t a -> PhaseNum
length [LocatedN RdrName]
names forall a. Ord a => a -> a -> Bool
> PhaseNum
1
    then R ()
breakpoint forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
inci R ()
body
    else R ()
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
body

p_classOpSig ::
  -- | Whether this is a \"default\" signature
  Bool ->
  -- | Names (before @::@)
  [LocatedN RdrName] ->
  -- | Type
  LHsSigType GhcPs ->
  R ()
p_classOpSig :: Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_classOpSig Bool
def [LocatedN RdrName]
names LHsSigType GhcPs
sigType = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
def (Text -> R ()
txt Text
"default" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space)
  Bool -> [LocatedN RdrName] -> LHsSigType GhcPs -> R ()
p_typeSig Bool
True [LocatedN RdrName]
names LHsSigType GhcPs
sigType

p_fixSig ::
  FixitySig GhcPs ->
  R ()
p_fixSig :: FixitySig GhcPs -> R ()
p_fixSig = \case
  FixitySig NoExtField
XFixitySig GhcPs
NoExtField [LIdP GhcPs]
names (Fixity SourceText
_ PhaseNum
n FixityDirection
dir) -> do
    Text -> R ()
txt forall a b. (a -> b) -> a -> b
$ case FixityDirection
dir of
      FixityDirection
InfixL -> Text
"infixl"
      FixityDirection
InfixR -> Text
"infixr"
      FixityDirection
InfixN -> Text
"infix"
    R ()
space
    forall a. Outputable a => a -> R ()
atom PhaseNum
n
    R ()
space
    R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$ forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel LocatedN RdrName -> R ()
p_rdrName [LIdP GhcPs]
names

p_inlineSig ::
  -- | Name
  LocatedN RdrName ->
  -- | Inline pragma specification
  InlinePragma ->
  R ()
p_inlineSig :: LocatedN RdrName -> InlinePragma -> R ()
p_inlineSig LocatedN RdrName
name InlinePragma {Maybe PhaseNum
Activation
RuleMatchInfo
InlineSpec
SourceText
inl_src :: InlinePragma -> SourceText
inl_inline :: InlinePragma -> InlineSpec
inl_sat :: InlinePragma -> Maybe PhaseNum
inl_act :: InlinePragma -> Activation
inl_rule :: InlinePragma -> RuleMatchInfo
inl_rule :: RuleMatchInfo
inl_act :: Activation
inl_sat :: Maybe PhaseNum
inl_inline :: InlineSpec
inl_src :: SourceText
..} = R () -> R ()
pragmaBraces forall a b. (a -> b) -> a -> b
$ do
  InlineSpec -> R ()
p_inlineSpec InlineSpec
inl_inline
  R ()
space
  case RuleMatchInfo
inl_rule of
    RuleMatchInfo
ConLike -> Text -> R ()
txt Text
"CONLIKE"
    RuleMatchInfo
FunLike -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  R ()
space
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Activation
inl_act forall a. Eq a => a -> a -> Bool
/= Activation
NeverActive) forall a b. (a -> b) -> a -> b
$ Activation -> R ()
p_activation Activation
inl_act
  R ()
space
  LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
name

p_specSig ::
  -- | Name
  LocatedN RdrName ->
  -- | The types to specialize to
  [LHsSigType GhcPs] ->
  -- | For specialize inline
  InlinePragma ->
  R ()
p_specSig :: LocatedN RdrName -> [LHsSigType GhcPs] -> InlinePragma -> R ()
p_specSig LocatedN RdrName
name [LHsSigType GhcPs]
ts InlinePragma {Maybe PhaseNum
Activation
RuleMatchInfo
InlineSpec
SourceText
inl_rule :: RuleMatchInfo
inl_act :: Activation
inl_sat :: Maybe PhaseNum
inl_inline :: InlineSpec
inl_src :: SourceText
inl_src :: InlinePragma -> SourceText
inl_inline :: InlinePragma -> InlineSpec
inl_sat :: InlinePragma -> Maybe PhaseNum
inl_act :: InlinePragma -> Activation
inl_rule :: InlinePragma -> RuleMatchInfo
..} = R () -> R ()
pragmaBraces forall a b. (a -> b) -> a -> b
$ do
  Text -> R ()
txt Text
"SPECIALIZE"
  R ()
space
  InlineSpec -> R ()
p_inlineSpec InlineSpec
inl_inline
  R ()
space
  Activation -> R ()
p_activation Activation
inl_act
  R ()
space
  LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
name
  R ()
space
  R ()
token'dcolon
  R ()
breakpoint
  R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' HsSigType GhcPs -> R ()
p_hsSigType) [LHsSigType GhcPs]
ts

p_inlineSpec :: InlineSpec -> R ()
p_inlineSpec :: InlineSpec -> R ()
p_inlineSpec = \case
  Inline SourceText
_ -> Text -> R ()
txt Text
"INLINE"
  Inlinable SourceText
_ -> Text -> R ()
txt Text
"INLINEABLE"
  NoInline SourceText
_ -> Text -> R ()
txt Text
"NOINLINE"
  Opaque SourceText
_ -> Text -> R ()
txt Text
"OPAQUE"
  InlineSpec
NoUserInlinePrag -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

p_activation :: Activation -> R ()
p_activation :: Activation -> R ()
p_activation = \case
  Activation
NeverActive -> Text -> R ()
txt Text
"[~]"
  Activation
AlwaysActive -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ActiveBefore SourceText
_ PhaseNum
n -> do
    Text -> R ()
txt Text
"[~"
    forall a. Outputable a => a -> R ()
atom PhaseNum
n
    Text -> R ()
txt Text
"]"
  ActiveAfter SourceText
_ PhaseNum
n -> do
    Text -> R ()
txt Text
"["
    forall a. Outputable a => a -> R ()
atom PhaseNum
n
    Text -> R ()
txt Text
"]"
  Activation
FinalActive -> forall a. String -> a
notImplemented String
"FinalActive" -- NOTE(amesgen) is this unreachable or just not implemented?

p_specInstSig :: LHsSigType GhcPs -> R ()
p_specInstSig :: LHsSigType GhcPs -> R ()
p_specInstSig LHsSigType GhcPs
sigType =
  Text -> R () -> R ()
pragma Text
"SPECIALIZE instance" forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$
    forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LHsSigType GhcPs
sigType HsSigType GhcPs -> R ()
p_hsSigType

p_minimalSig ::
  -- | Boolean formula
  LBooleanFormula (LocatedN RdrName) ->
  R ()
p_minimalSig :: LBooleanFormula (LocatedN RdrName) -> R ()
p_minimalSig =
  forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' forall a b. (a -> b) -> a -> b
$ \BooleanFormula (LocatedN RdrName)
booleanFormula ->
    Text -> R () -> R ()
pragma Text
"MINIMAL" (R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ BooleanFormula (LocatedN RdrName) -> R ()
p_booleanFormula BooleanFormula (LocatedN RdrName)
booleanFormula)

p_booleanFormula ::
  -- | Boolean formula
  BooleanFormula (LocatedN RdrName) ->
  R ()
p_booleanFormula :: BooleanFormula (LocatedN RdrName) -> R ()
p_booleanFormula = \case
  Var LocatedN RdrName
name -> LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
name
  And [LBooleanFormula (LocatedN RdrName)]
xs ->
    R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$
      forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
        R ()
commaDel
        (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' BooleanFormula (LocatedN RdrName) -> R ()
p_booleanFormula)
        [LBooleanFormula (LocatedN RdrName)]
xs
  Or [LBooleanFormula (LocatedN RdrName)]
xs ->
    R () -> R ()
sitcc forall a b. (a -> b) -> a -> b
$
      forall a. R () -> (a -> R ()) -> [a] -> R ()
sep
        (R ()
breakpoint forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> R ()
txt Text
"|" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space)
        (forall l a. HasSrcSpan l => (a -> R ()) -> GenLocated l a -> R ()
located' BooleanFormula (LocatedN RdrName) -> R ()
p_booleanFormula)
        [LBooleanFormula (LocatedN RdrName)]
xs
  Parens LBooleanFormula (LocatedN RdrName)
l -> forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located LBooleanFormula (LocatedN RdrName)
l (BracketStyle -> R () -> R ()
parens BracketStyle
N forall b c a. (b -> c) -> (a -> b) -> a -> c
. BooleanFormula (LocatedN RdrName) -> R ()
p_booleanFormula)

p_completeSig ::
  -- | Constructors\/patterns
  Located [LocatedN RdrName] ->
  -- | Type
  Maybe (LocatedN RdrName) ->
  R ()
p_completeSig :: Located [LocatedN RdrName] -> Maybe (LocatedN RdrName) -> R ()
p_completeSig Located [LocatedN RdrName]
cs' Maybe (LocatedN RdrName)
mty =
  forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
located Located [LocatedN RdrName]
cs' forall a b. (a -> b) -> a -> b
$ \[LocatedN RdrName]
cs ->
    Text -> R () -> R ()
pragma Text
"COMPLETE" forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
      forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel LocatedN RdrName -> R ()
p_rdrName [LocatedN RdrName]
cs
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (LocatedN RdrName)
mty forall a b. (a -> b) -> a -> b
$ \LocatedN RdrName
ty -> do
        R ()
space
        R ()
token'dcolon
        R ()
breakpoint
        R () -> R ()
inci (LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
ty)

p_sccSig :: LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R ()
p_sccSig :: LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> R ()
p_sccSig LocatedN RdrName
loc Maybe (XRec GhcPs StringLiteral)
literal = Text -> R () -> R ()
pragma Text
"SCC" forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
  LocatedN RdrName -> R ()
p_rdrName LocatedN RdrName
loc
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (XRec GhcPs StringLiteral)
literal forall a b. (a -> b) -> a -> b
$ \GenLocated (SrcAnn NoEpAnns) StringLiteral
x -> do
    R ()
breakpoint
    forall a. Outputable a => a -> R ()
atom GenLocated (SrcAnn NoEpAnns) StringLiteral
x

p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
p_standaloneKindSig (StandaloneKindSig XStandaloneKindSig GhcPs
_ LIdP GhcPs
name LHsSigType GhcPs
sigTy) = do
  Text -> R ()
txt Text
"type"
  R () -> R ()
inci forall a b. (a -> b) -> a -> b
$ do
    R ()
space
    LocatedN RdrName -> R ()
p_rdrName LIdP GhcPs
name
    forall l a. HasSrcSpan l => GenLocated l a -> (a -> R ()) -> R ()
startTypeAnnotation LHsSigType GhcPs
sigTy HsSigType GhcPs -> R ()
p_hsSigType