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