{-# 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 BasicTypes
import BooleanFormula
import Control.Monad
import GHC
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 NoExtField names :: [Located (IdP GhcPs)]
names hswc :: LHsSigWcType GhcPs
hswc -> Bool -> [Located RdrName] -> LHsSigWcType GhcPs -> R ()
p_typeSig Bool
True [Located (IdP GhcPs)]
[Located RdrName]
names LHsSigWcType GhcPs
hswc
  PatSynSig NoExtField names :: [Located (IdP GhcPs)]
names hsib :: LHsSigType GhcPs
hsib -> [Located RdrName] -> LHsSigType GhcPs -> R ()
p_patSynSig [Located (IdP GhcPs)]
[Located RdrName]
names LHsSigType GhcPs
hsib
  ClassOpSig NoExtField def :: Bool
def names :: [Located (IdP GhcPs)]
names hsib :: LHsSigType GhcPs
hsib -> Bool -> [Located RdrName] -> LHsSigType GhcPs -> R ()
p_classOpSig Bool
def [Located (IdP GhcPs)]
[Located RdrName]
names LHsSigType GhcPs
hsib
  FixSig NoExtField sig :: FixitySig GhcPs
sig -> FixitySig GhcPs -> R ()
p_fixSig FixitySig GhcPs
sig
  InlineSig NoExtField name :: Located (IdP GhcPs)
name inlinePragma :: InlinePragma
inlinePragma -> Located RdrName -> InlinePragma -> R ()
p_inlineSig Located (IdP GhcPs)
Located RdrName
name InlinePragma
inlinePragma
  SpecSig NoExtField name :: Located (IdP GhcPs)
name ts :: [LHsSigType GhcPs]
ts inlinePragma :: InlinePragma
inlinePragma -> Located RdrName -> [LHsSigType GhcPs] -> InlinePragma -> R ()
p_specSig Located (IdP GhcPs)
Located RdrName
name [LHsSigType GhcPs]
ts InlinePragma
inlinePragma
  SpecInstSig NoExtField _ hsib :: LHsSigType GhcPs
hsib -> LHsSigType GhcPs -> R ()
p_specInstSig LHsSigType GhcPs
hsib
  MinimalSig NoExtField _ booleanFormula :: LBooleanFormula (Located (IdP GhcPs))
booleanFormula -> LBooleanFormula (Located RdrName) -> R ()
p_minimalSig LBooleanFormula (Located (IdP GhcPs))
LBooleanFormula (Located RdrName)
booleanFormula
  CompleteMatchSig NoExtField _sourceText :: SourceText
_sourceText cs :: Located [Located (IdP GhcPs)]
cs ty :: Maybe (Located (IdP GhcPs))
ty -> Located [Located RdrName] -> Maybe (Located RdrName) -> R ()
p_completeSig Located [Located (IdP GhcPs)]
Located [Located RdrName]
cs Maybe (Located (IdP GhcPs))
Maybe (Located RdrName)
ty
  SCCFunSig NoExtField _ name :: Located (IdP GhcPs)
name literal :: Maybe (Located StringLiteral)
literal -> Located (IdP GhcPs) -> Maybe (Located StringLiteral) -> R ()
p_sccSig Located (IdP GhcPs)
name Maybe (Located StringLiteral)
literal
  _ -> String -> R ()
forall a. String -> a
notImplemented "certain types of signature declarations"

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

p_typeAscription ::
  LHsSigWcType GhcPs ->
  R ()
p_typeAscription :: LHsSigWcType GhcPs -> R ()
p_typeAscription HsWC {..} = R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
  R ()
space
  Text -> R ()
txt "::"
  let t :: LHsType GhcPs
t = LHsSigType GhcPs -> LHsType GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body LHsSigType GhcPs
hswc_body
  if HsType GhcPs -> Bool
hasDocStrings (LHsType GhcPs -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
t)
    then R ()
newline
    else R ()
breakpoint
  LHsType GhcPs -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsType GhcPs
t HsType GhcPs -> R ()
p_hsType
p_typeAscription (XHsWildCardBndrs x :: XXHsWildCardBndrs GhcPs (LHsSigType GhcPs)
x) = NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsWildCardBndrs GhcPs (LHsSigType GhcPs)
x

p_patSynSig ::
  [Located RdrName] ->
  HsImplicitBndrs GhcPs (LHsType GhcPs) ->
  R ()
p_patSynSig :: [Located RdrName] -> LHsSigType GhcPs -> R ()
p_patSynSig names :: [Located RdrName]
names hsib :: LHsSigType GhcPs
hsib = do
  Text -> R ()
txt "pattern"
  let body :: R ()
body =
        Bool -> [Located RdrName] -> LHsSigWcType GhcPs -> R ()
p_typeSig
          Bool
False
          [Located RdrName]
names
          HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC {hswc_ext :: XHsWC GhcPs (LHsSigType GhcPs)
hswc_ext = NoExtField
XHsWC GhcPs (LHsSigType GhcPs)
NoExtField, hswc_body :: LHsSigType GhcPs
hswc_body = LHsSigType GhcPs
hsib}
  if [Located RdrName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Located RdrName]
names Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1
    then R ()
breakpoint R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R () -> R ()
inci R ()
body
    else R ()
space R () -> R () -> R ()
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 @::@)
  [Located RdrName] ->
  -- | Type
  HsImplicitBndrs GhcPs (LHsType GhcPs) ->
  R ()
p_classOpSig :: Bool -> [Located RdrName] -> LHsSigType GhcPs -> R ()
p_classOpSig def :: Bool
def names :: [Located RdrName]
names hsib :: LHsSigType GhcPs
hsib = do
  Bool -> R () -> R ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
def (Text -> R ()
txt "default" R () -> R () -> R ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> R ()
space)
  Bool -> [Located RdrName] -> LHsSigWcType GhcPs -> R ()
p_typeSig Bool
True [Located RdrName]
names HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC {hswc_ext :: XHsWC GhcPs (LHsSigType GhcPs)
hswc_ext = NoExtField
XHsWC GhcPs (LHsSigType GhcPs)
NoExtField, hswc_body :: LHsSigType GhcPs
hswc_body = LHsSigType GhcPs
hsib}

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

p_inlineSig ::
  -- | Name
  Located RdrName ->
  -- | Inline pragma specification
  InlinePragma ->
  R ()
p_inlineSig :: Located RdrName -> InlinePragma -> R ()
p_inlineSig name :: Located RdrName
name InlinePragma {..} = R () -> R ()
pragmaBraces (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
  InlineSpec -> R ()
p_inlineSpec InlineSpec
inl_inline
  R ()
space
  case RuleMatchInfo
inl_rule of
    ConLike -> Text -> R ()
txt "CONLIKE"
    FunLike -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  R ()
space
  Activation -> R ()
p_activation Activation
inl_act
  R ()
space
  Located RdrName -> R ()
p_rdrName Located RdrName
name

p_specSig ::
  -- | Name
  Located RdrName ->
  -- | The types to specialize to
  [LHsSigType GhcPs] ->
  -- | For specialize inline
  InlinePragma ->
  R ()
p_specSig :: Located RdrName -> [LHsSigType GhcPs] -> InlinePragma -> R ()
p_specSig name :: Located RdrName
name ts :: [LHsSigType GhcPs]
ts InlinePragma {..} = R () -> R ()
pragmaBraces (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
  Text -> R ()
txt "SPECIALIZE"
  R ()
space
  InlineSpec -> R ()
p_inlineSpec InlineSpec
inl_inline
  R ()
space
  Activation -> R ()
p_activation Activation
inl_act
  R ()
space
  Located RdrName -> R ()
p_rdrName Located RdrName
name
  R ()
space
  Text -> R ()
txt "::"
  R ()
breakpoint
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> (LHsSigType GhcPs -> R ()) -> [LHsSigType GhcPs] -> R ()
forall a. R () -> (a -> R ()) -> [a] -> R ()
sep R ()
commaDel ((HsType GhcPs -> R ()) -> LHsType GhcPs -> R ()
forall a. (a -> R ()) -> Located a -> R ()
located' HsType GhcPs -> R ()
p_hsType (LHsType GhcPs -> R ())
-> (LHsSigType GhcPs -> LHsType GhcPs) -> LHsSigType GhcPs -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsSigType GhcPs -> LHsType GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body) [LHsSigType GhcPs]
ts

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

p_activation :: Activation -> R ()
p_activation :: Activation -> R ()
p_activation = \case
  NeverActive -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  AlwaysActive -> () -> R ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ActiveBefore _ n :: Int
n -> do
    Text -> R ()
txt "[~"
    Int -> R ()
forall a. Outputable a => a -> R ()
atom Int
n
    Text -> R ()
txt "]"
  ActiveAfter _ n :: Int
n -> do
    Text -> R ()
txt "["
    Int -> R ()
forall a. Outputable a => a -> R ()
atom Int
n
    Text -> R ()
txt "]"

p_specInstSig :: LHsSigType GhcPs -> R ()
p_specInstSig :: LHsSigType GhcPs -> R ()
p_specInstSig hsib :: LHsSigType GhcPs
hsib =
  Text -> R () -> R ()
pragma "SPECIALIZE instance" (R () -> R ()) -> (R () -> R ()) -> R () -> R ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$
    LHsType GhcPs -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located (LHsSigType GhcPs -> LHsType GhcPs
forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body LHsSigType GhcPs
hsib) HsType GhcPs -> R ()
p_hsType

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

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

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

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

p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
p_standaloneKindSig (StandaloneKindSig NoExtField name :: Located (IdP GhcPs)
name bndrs :: LHsSigType GhcPs
bndrs) = do
  Text -> R ()
txt "type"
  R () -> R ()
inci (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ do
    R ()
space
    Located RdrName -> R ()
p_rdrName Located (IdP GhcPs)
Located RdrName
name
    R ()
space
    Text -> R ()
txt "::"
    R ()
breakpoint
    case LHsSigType GhcPs
bndrs of
      HsIB NoExtField sig :: LHsType GhcPs
sig -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R ()
forall a. Located a -> (a -> R ()) -> R ()
located LHsType GhcPs
sig HsType GhcPs -> R ()
p_hsType
      XHsImplicitBndrs x :: XXHsImplicitBndrs GhcPs (LHsType GhcPs)
x -> NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXHsImplicitBndrs GhcPs (LHsType GhcPs)
x
p_standaloneKindSig (XStandaloneKindSig c :: XXStandaloneKindSig GhcPs
c) = NoExtCon -> R ()
forall a. NoExtCon -> a
noExtCon NoExtCon
XXStandaloneKindSig GhcPs
c