1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE TypeFamilies #-}
6
7-- | Rendering of types.
8module Ormolu.Printer.Meat.Type
9  ( p_hsType,
10    p_hsTypePostDoc,
11    hasDocStrings,
12    p_hsContext,
13    p_hsTyVarBndr,
14    ForAllVisibility (..),
15    p_forallBndrs,
16    p_conDeclFields,
17    p_lhsTypeArg,
18    p_hsSigType,
19    tyVarsToTyPats,
20    hsOuterTyVarBndrsToHsType,
21    lhsTypeToSigType,
22  )
23where
24
25import Data.Foldable (for_)
26import GHC.Hs
27import GHC.Types.Basic hiding (isPromoted)
28import GHC.Types.Name.Reader
29import GHC.Types.SourceText
30import GHC.Types.SrcLoc
31import GHC.Types.Var
32import Ormolu.Printer.Combinators
33import Ormolu.Printer.Meat.Common
34import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit)
35import Ormolu.Printer.Operators
36import Ormolu.Utils
37
38p_hsType :: HsType GhcPs -> R ()
39p_hsType t = p_hsType' (hasDocStrings t) PipeStyle t
40
41p_hsTypePostDoc :: HsType GhcPs -> R ()
42p_hsTypePostDoc t = p_hsType' (hasDocStrings t) CaretStyle t
43
44-- | How to render Haddocks associated with a type.
45data TypeDocStyle
46  = PipeStyle
47  | CaretStyle
48
49p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R ()
50p_hsType' multilineArgs docStyle = \case
51  HsForAllTy _ tele t -> do
52    case tele of
53      HsForAllInvis _ bndrs -> p_forallBndrs ForAllInvis p_hsTyVarBndr bndrs
54      HsForAllVis _ bndrs -> p_forallBndrs ForAllVis p_hsTyVarBndr bndrs
55    interArgBreak
56    p_hsTypeR (unLoc t)
57  HsQualTy _ qs' t -> do
58    for_ qs' $ \qs -> do
59      located qs p_hsContext
60      space
61      txt "=>"
62      interArgBreak
63    case unLoc t of
64      HsQualTy {} -> p_hsTypeR (unLoc t)
65      HsFunTy {} -> p_hsTypeR (unLoc t)
66      _ -> located t p_hsTypeR
67  HsTyVar _ p n -> do
68    case p of
69      IsPromoted -> do
70        txt "'"
71        case showOutputable (unLoc n) of
72          _ : '\'' : _ -> space
73          _ -> return ()
74      NotPromoted -> return ()
75    p_rdrName n
76  HsAppTy _ f x -> do
77    let -- In order to format type applications with multiple parameters
78        -- nicer, traverse the AST to gather the function and all the
79        -- parameters together.
80        gatherArgs f' knownArgs =
81          case f' of
82            L _ (HsAppTy _ l r) -> gatherArgs l (r : knownArgs)
83            _ -> (f', knownArgs)
84        (func, args) = gatherArgs f [x]
85    switchLayout (getLocA f : fmap getLocA args) . sitcc $ do
86      located func p_hsType
87      breakpoint
88      inci $
89        sep breakpoint (located' p_hsType) args
90  HsAppKindTy _ ty kd -> sitcc $ do
91    -- The first argument is the location of the "@..." part. Not 100% sure,
92    -- but I think we can ignore it as long as we use 'located' on both the
93    -- type and the kind.
94    located ty p_hsType
95    breakpoint
96    inci $ do
97      txt "@"
98      located kd p_hsType
99  HsFunTy _ arrow x y@(L _ y') -> do
100    located x p_hsType
101    space
102    case arrow of
103      HsUnrestrictedArrow _ -> txt "->"
104      HsLinearArrow _ _ -> txt "%1 ->"
105      HsExplicitMult _ _ mult -> do
106        txt "%"
107        p_hsTypeR (unLoc mult)
108        space
109        txt "->"
110    interArgBreak
111    case y' of
112      HsFunTy {} -> p_hsTypeR y'
113      _ -> located y p_hsTypeR
114  HsListTy _ t ->
115    located t (brackets N . p_hsType)
116  HsTupleTy _ tsort xs ->
117    let parens' =
118          case tsort of
119            HsUnboxedTuple -> parensHash N
120            HsBoxedOrConstraintTuple -> parens N
121     in parens' $ sep commaDel (sitcc . located' p_hsType) xs
122  HsSumTy _ xs ->
123    parensHash N $
124      sep (txt "|" >> breakpoint) (sitcc . located' p_hsType) xs
125  HsOpTy _ x op y ->
126    sitcc $
127      let opTree = OpBranch (tyOpTree x) op (tyOpTree y)
128       in p_tyOpTree (reassociateOpTree Just opTree)
129  HsParTy _ t ->
130    parens N (located t p_hsType)
131  HsIParamTy _ n t -> sitcc $ do
132    located n atom
133    space
134    txt "::"
135    breakpoint
136    inci (located t p_hsType)
137  HsStarTy _ _ -> txt "*"
138  HsKindSig _ t k -> sitcc $ do
139    located t p_hsType
140    space
141    txt "::"
142    breakpoint
143    inci (located k p_hsType)
144  HsSpliceTy _ splice -> p_hsSplice splice
145  HsDocTy _ t str ->
146    case docStyle of
147      PipeStyle -> do
148        p_hsDocString Pipe True str
149        located t p_hsType
150      CaretStyle -> do
151        located t p_hsType
152        newline
153        p_hsDocString Caret False str
154  HsBangTy _ (HsSrcBang _ u s) t -> do
155    case u of
156      SrcUnpack -> txt "{-# UNPACK #-}" >> space
157      SrcNoUnpack -> txt "{-# NOUNPACK #-}" >> space
158      NoSrcUnpack -> return ()
159    case s of
160      SrcLazy -> txt "~"
161      SrcStrict -> txt "!"
162      NoSrcStrict -> return ()
163    located t p_hsType
164  HsRecTy _ fields ->
165    p_conDeclFields fields
166  HsExplicitListTy _ p xs -> do
167    case p of
168      IsPromoted -> txt "'"
169      NotPromoted -> return ()
170    brackets N $ do
171      -- If both this list itself and the first element is promoted,
172      -- we need to put a space in between or it fails to parse.
173      case (p, xs) of
174        (IsPromoted, L _ t : _) | isPromoted t -> space
175        _ -> return ()
176      sep commaDel (sitcc . located' p_hsType) xs
177  HsExplicitTupleTy _ xs -> do
178    txt "'"
179    parens N $ do
180      case xs of
181        L _ t : _ | isPromoted t -> space
182        _ -> return ()
183      sep commaDel (located' p_hsType) xs
184  HsTyLit _ t ->
185    case t of
186      HsStrTy (SourceText s) _ -> p_stringLit s
187      a -> atom a
188  HsWildCardTy _ -> txt "_"
189  XHsType t -> atom t
190  where
191    isPromoted = \case
192      HsAppTy _ (L _ f) _ -> isPromoted f
193      HsTyVar _ IsPromoted _ -> True
194      HsExplicitTupleTy {} -> True
195      HsExplicitListTy {} -> True
196      _ -> False
197    interArgBreak =
198      if multilineArgs
199        then newline
200        else breakpoint
201    p_hsTypeR = p_hsType' multilineArgs docStyle
202
203-- | Return 'True' if at least one argument in 'HsType' has a doc string
204-- attached to it.
205hasDocStrings :: HsType GhcPs -> Bool
206hasDocStrings = \case
207  HsDocTy {} -> True
208  HsFunTy _ _ (L _ x) (L _ y) -> hasDocStrings x || hasDocStrings y
209  HsForAllTy _ _ (L _ x) -> hasDocStrings x
210  HsQualTy _ _ (L _ x) -> hasDocStrings x
211  _ -> False
212
213p_hsContext :: HsContext GhcPs -> R ()
214p_hsContext = \case
215  [] -> txt "()"
216  [x] -> located x p_hsType
217  xs -> parens N $ sep commaDel (sitcc . located' p_hsType) xs
218
219class IsInferredTyVarBndr flag where
220  isInferred :: flag -> Bool
221
222instance IsInferredTyVarBndr () where
223  isInferred () = False
224
225instance IsInferredTyVarBndr Specificity where
226  isInferred = \case
227    InferredSpec -> True
228    SpecifiedSpec -> False
229
230p_hsTyVarBndr :: IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R ()
231p_hsTyVarBndr = \case
232  UserTyVar _ flag x ->
233    (if isInferred flag then braces N else id) $ p_rdrName x
234  KindedTyVar _ flag l k -> (if isInferred flag then braces else parens) N $ do
235    located l atom
236    space
237    txt "::"
238    breakpoint
239    inci (located k p_hsType)
240
241data ForAllVisibility = ForAllInvis | ForAllVis
242
243-- | Render several @forall@-ed variables.
244p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [LocatedA a] -> R ()
245p_forallBndrs ForAllInvis _ [] = txt "forall."
246p_forallBndrs ForAllVis _ [] = txt "forall ->"
247p_forallBndrs vis p tyvars =
248  switchLayout (getLocA <$> tyvars) $ do
249    txt "forall"
250    breakpoint
251    inci $ do
252      sitcc $ sep breakpoint (sitcc . located' p) tyvars
253      case vis of
254        ForAllInvis -> txt "."
255        ForAllVis -> space >> txt "->"
256
257p_conDeclFields :: [LConDeclField GhcPs] -> R ()
258p_conDeclFields xs =
259  braces N $ sep commaDel (sitcc . located' p_conDeclField) xs
260
261p_conDeclField :: ConDeclField GhcPs -> R ()
262p_conDeclField ConDeclField {..} = do
263  mapM_ (p_hsDocString Pipe True) cd_fld_doc
264  sitcc $
265    sep
266      commaDel
267      (located' (p_rdrName . rdrNameFieldOcc))
268      cd_fld_names
269  space
270  txt "::"
271  breakpoint
272  sitcc . inci $ p_hsType (unLoc cd_fld_type)
273
274tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (LocatedN RdrName)
275tyOpTree (L _ (HsOpTy _ l op r)) =
276  OpBranch (tyOpTree l) op (tyOpTree r)
277tyOpTree n = OpNode n
278
279p_tyOpTree :: OpTree (LHsType GhcPs) (LocatedN RdrName) -> R ()
280p_tyOpTree (OpNode n) = located n p_hsType
281p_tyOpTree (OpBranch l op r) = do
282  switchLayout [opTreeLoc l] $
283    p_tyOpTree l
284  breakpoint
285  inci . switchLayout [opTreeLoc r] $ do
286    p_rdrName op
287    space
288    p_tyOpTree r
289
290p_lhsTypeArg :: LHsTypeArg GhcPs -> R ()
291p_lhsTypeArg = \case
292  HsValArg ty -> located ty p_hsType
293  -- first argument is the SrcSpan of the @,
294  -- but the @ always has to be directly before the type argument
295  HsTypeArg _ ty -> txt "@" *> located ty p_hsType
296  -- NOTE(amesgen) is this unreachable or just not implemented?
297  HsArgPar _ -> notImplemented "HsArgPar"
298
299p_hsSigType :: HsSigType GhcPs -> R ()
300p_hsSigType HsSig {..} =
301  p_hsType $ hsOuterTyVarBndrsToHsType sig_bndrs sig_body
302
303----------------------------------------------------------------------------
304-- Conversion functions
305
306tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs
307tyVarToType = \case
308  UserTyVar _ () tvar -> HsTyVar EpAnnNotUsed NotPromoted tvar
309  KindedTyVar _ () tvar kind ->
310    -- Note: we always add parentheses because for whatever reason GHC does
311    -- not use HsParTy for left-hand sides of declarations. Please see
312    -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as
313    -- long as 'tyVarToType' does not get applied to right-hand sides of
314    -- declarations.
315    HsParTy EpAnnNotUsed . noLocA $
316      HsKindSig EpAnnNotUsed (noLocA (HsTyVar EpAnnNotUsed NotPromoted tvar)) kind
317
318tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs
319tyVarsToTyPats HsQTvs {..} = HsValArg . fmap tyVarToType <$> hsq_explicit
320
321-- could be generalized to also handle () instead of Specificity
322hsOuterTyVarBndrsToHsType ::
323  HsOuterTyVarBndrs Specificity GhcPs ->
324  LHsType GhcPs ->
325  HsType GhcPs
326hsOuterTyVarBndrsToHsType obndrs ty = case obndrs of
327  HsOuterImplicit NoExtField -> unLoc ty
328  HsOuterExplicit _ bndrs ->
329    HsForAllTy NoExtField (mkHsForAllInvisTele EpAnnNotUsed bndrs) ty
330
331lhsTypeToSigType :: LHsType GhcPs -> LHsSigType GhcPs
332lhsTypeToSigType ty =
333  reLocA . L (getLocA ty) . HsSig NoExtField (HsOuterImplicit NoExtField) $ ty
334