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