1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RecordWildCards #-}
4
5-- | Type signature declarations.
6module Ormolu.Printer.Meat.Declaration.Signature
7  ( p_sigDecl,
8    p_typeAscription,
9    p_activation,
10    p_standaloneKindSig,
11  )
12where
13
14import BasicTypes
15import BooleanFormula
16import Control.Monad
17import GHC
18import Ormolu.Printer.Combinators
19import Ormolu.Printer.Meat.Common
20import Ormolu.Printer.Meat.Type
21import Ormolu.Utils
22
23p_sigDecl :: Sig GhcPs -> R ()
24p_sigDecl = \case
25  TypeSig NoExtField names hswc -> p_typeSig True names hswc
26  PatSynSig NoExtField names hsib -> p_patSynSig names hsib
27  ClassOpSig NoExtField def names hsib -> p_classOpSig def names hsib
28  FixSig NoExtField sig -> p_fixSig sig
29  InlineSig NoExtField name inlinePragma -> p_inlineSig name inlinePragma
30  SpecSig NoExtField name ts inlinePragma -> p_specSig name ts inlinePragma
31  SpecInstSig NoExtField _ hsib -> p_specInstSig hsib
32  MinimalSig NoExtField _ booleanFormula -> p_minimalSig booleanFormula
33  CompleteMatchSig NoExtField _sourceText cs ty -> p_completeSig cs ty
34  SCCFunSig NoExtField _ name literal -> p_sccSig name literal
35  _ -> notImplemented "certain types of signature declarations"
36
37p_typeSig ::
38  -- | Should the tail of the names be indented
39  Bool ->
40  -- | Names (before @::@)
41  [Located RdrName] ->
42  -- | Type
43  LHsSigWcType GhcPs ->
44  R ()
45p_typeSig _ [] _ = return () -- should not happen though
46p_typeSig indentTail (n : ns) hswc = do
47  p_rdrName n
48  if null ns
49    then p_typeAscription hswc
50    else inciIf indentTail $ do
51      commaDel
52      sep commaDel p_rdrName ns
53      p_typeAscription hswc
54
55p_typeAscription ::
56  LHsSigWcType GhcPs ->
57  R ()
58p_typeAscription HsWC {..} = inci $ do
59  space
60  txt "::"
61  let t = hsib_body hswc_body
62  if hasDocStrings (unLoc t)
63    then newline
64    else breakpoint
65  located t p_hsType
66p_typeAscription (XHsWildCardBndrs x) = noExtCon x
67
68p_patSynSig ::
69  [Located RdrName] ->
70  HsImplicitBndrs GhcPs (LHsType GhcPs) ->
71  R ()
72p_patSynSig names hsib = do
73  txt "pattern"
74  let body =
75        p_typeSig
76          False
77          names
78          HsWC {hswc_ext = NoExtField, hswc_body = hsib}
79  if length names > 1
80    then breakpoint >> inci body
81    else space >> body
82
83p_classOpSig ::
84  -- | Whether this is a \"default\" signature
85  Bool ->
86  -- | Names (before @::@)
87  [Located RdrName] ->
88  -- | Type
89  HsImplicitBndrs GhcPs (LHsType GhcPs) ->
90  R ()
91p_classOpSig def names hsib = do
92  when def (txt "default" >> space)
93  p_typeSig True names HsWC {hswc_ext = NoExtField, hswc_body = hsib}
94
95p_fixSig ::
96  FixitySig GhcPs ->
97  R ()
98p_fixSig = \case
99  FixitySig NoExtField names (Fixity _ n dir) -> do
100    txt $ case dir of
101      InfixL -> "infixl"
102      InfixR -> "infixr"
103      InfixN -> "infix"
104    space
105    atom n
106    space
107    sitcc $ sep commaDel p_rdrName names
108  XFixitySig x -> noExtCon x
109
110p_inlineSig ::
111  -- | Name
112  Located RdrName ->
113  -- | Inline pragma specification
114  InlinePragma ->
115  R ()
116p_inlineSig name InlinePragma {..} = pragmaBraces $ do
117  p_inlineSpec inl_inline
118  space
119  case inl_rule of
120    ConLike -> txt "CONLIKE"
121    FunLike -> return ()
122  space
123  p_activation inl_act
124  space
125  p_rdrName name
126
127p_specSig ::
128  -- | Name
129  Located RdrName ->
130  -- | The types to specialize to
131  [LHsSigType GhcPs] ->
132  -- | For specialize inline
133  InlinePragma ->
134  R ()
135p_specSig name ts InlinePragma {..} = pragmaBraces $ do
136  txt "SPECIALIZE"
137  space
138  p_inlineSpec inl_inline
139  space
140  p_activation inl_act
141  space
142  p_rdrName name
143  space
144  txt "::"
145  breakpoint
146  inci $ sep commaDel (located' p_hsType . hsib_body) ts
147
148p_inlineSpec :: InlineSpec -> R ()
149p_inlineSpec = \case
150  Inline -> txt "INLINE"
151  Inlinable -> txt "INLINEABLE"
152  NoInline -> txt "NOINLINE"
153  NoUserInline -> return ()
154
155p_activation :: Activation -> R ()
156p_activation = \case
157  NeverActive -> return ()
158  AlwaysActive -> return ()
159  ActiveBefore _ n -> do
160    txt "[~"
161    atom n
162    txt "]"
163  ActiveAfter _ n -> do
164    txt "["
165    atom n
166    txt "]"
167
168p_specInstSig :: LHsSigType GhcPs -> R ()
169p_specInstSig hsib =
170  pragma "SPECIALIZE instance" . inci $
171    located (hsib_body hsib) p_hsType
172
173p_minimalSig ::
174  -- | Boolean formula
175  LBooleanFormula (Located RdrName) ->
176  R ()
177p_minimalSig =
178  located' $ \booleanFormula ->
179    pragma "MINIMAL" (inci $ p_booleanFormula booleanFormula)
180
181p_booleanFormula ::
182  -- | Boolean formula
183  BooleanFormula (Located RdrName) ->
184  R ()
185p_booleanFormula = \case
186  Var name -> p_rdrName name
187  And xs ->
188    sitcc $
189      sep
190        commaDel
191        (located' p_booleanFormula)
192        xs
193  Or xs ->
194    sitcc $
195      sep
196        (breakpoint >> txt "|" >> space)
197        (located' p_booleanFormula)
198        xs
199  Parens l -> located l (parens N . p_booleanFormula)
200
201p_completeSig ::
202  -- | Constructors\/patterns
203  Located [Located RdrName] ->
204  -- | Type
205  Maybe (Located RdrName) ->
206  R ()
207p_completeSig cs' mty =
208  located cs' $ \cs ->
209    pragma "COMPLETE" . inci $ do
210      sep commaDel p_rdrName cs
211      forM_ mty $ \ty -> do
212        space
213        txt "::"
214        breakpoint
215        inci (p_rdrName ty)
216
217p_sccSig :: Located (IdP GhcPs) -> Maybe (Located StringLiteral) -> R ()
218p_sccSig loc literal = pragma "SCC" . inci $ do
219  p_rdrName loc
220  forM_ literal $ \x -> do
221    breakpoint
222    atom x
223
224p_standaloneKindSig :: StandaloneKindSig GhcPs -> R ()
225p_standaloneKindSig (StandaloneKindSig NoExtField name bndrs) = do
226  txt "type"
227  inci $ do
228    space
229    p_rdrName name
230    space
231    txt "::"
232    breakpoint
233    case bndrs of
234      HsIB NoExtField sig -> located sig p_hsType
235      XHsImplicitBndrs x -> noExtCon x
236p_standaloneKindSig (XStandaloneKindSig c) = noExtCon c
237