{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -- | Rendering of types. module Ormolu.Printer.Meat.Type ( p_hsType, p_hsTypePostDoc, hasDocStrings, p_hsContext, p_hsTyVarBndr, ForAllVisibility (..), p_forallBndrs, p_conDeclFields, p_lhsTypeArg, tyVarsToTypes, tyVarsToTyPats, ) where import Data.Data (Data) import GHC.Hs.Decls import GHC.Hs.Extension import GHC.Hs.Type import GHC.Types.Basic hiding (isPromoted) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.Var import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration.Value (p_hsSplice, p_stringLit) import Ormolu.Printer.Operators import Ormolu.Utils p_hsType :: HsType GhcPs -> R () p_hsType :: HsType GhcPs -> R () p_hsType HsType GhcPs t = Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' (HsType GhcPs -> Bool hasDocStrings HsType GhcPs t) TypeDocStyle PipeStyle HsType GhcPs t p_hsTypePostDoc :: HsType GhcPs -> R () p_hsTypePostDoc :: HsType GhcPs -> R () p_hsTypePostDoc HsType GhcPs t = Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' (HsType GhcPs -> Bool hasDocStrings HsType GhcPs t) TypeDocStyle CaretStyle HsType GhcPs t -- | How to render Haddocks associated with a type. data TypeDocStyle = PipeStyle | CaretStyle p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' :: Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' Bool multilineArgs TypeDocStyle docStyle = \case HsForAllTy XForAllTy GhcPs NoExtField HsForAllTelescope GhcPs tele LHsType GhcPs t -> do case HsForAllTelescope GhcPs tele of HsForAllInvis XHsForAllInvis GhcPs NoExtField [LHsTyVarBndr Specificity GhcPs] bndrs -> ForAllVisibility -> (HsTyVarBndr Specificity GhcPs -> R ()) -> [LHsTyVarBndr Specificity GhcPs] -> R () forall a. Data a => ForAllVisibility -> (a -> R ()) -> [Located a] -> R () p_forallBndrs ForAllVisibility ForAllInvis HsTyVarBndr Specificity GhcPs -> R () forall flag. IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr [LHsTyVarBndr Specificity GhcPs] bndrs HsForAllVis XHsForAllVis GhcPs NoExtField [LHsTyVarBndr () GhcPs] bndrs -> ForAllVisibility -> (HsTyVarBndr () GhcPs -> R ()) -> [LHsTyVarBndr () GhcPs] -> R () forall a. Data a => ForAllVisibility -> (a -> R ()) -> [Located a] -> R () p_forallBndrs ForAllVisibility ForAllVis HsTyVarBndr () GhcPs -> R () forall flag. IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr [LHsTyVarBndr () GhcPs] bndrs R () interArgBreak HsType GhcPs -> R () p_hsTypeR (LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs t) HsQualTy XQualTy GhcPs NoExtField LHsContext GhcPs qs LHsType GhcPs t -> do LHsContext GhcPs -> (HsContext GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsContext GhcPs qs HsContext GhcPs -> R () p_hsContext R () space Text -> R () txt Text "=>" R () interArgBreak case LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs t of HsQualTy {} -> HsType GhcPs -> R () p_hsTypeR (LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs t) HsFunTy {} -> HsType GhcPs -> R () p_hsTypeR (LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs t) HsType GhcPs _ -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsTypeR HsTyVar XTyVar GhcPs NoExtField PromotionFlag p Located (IdP GhcPs) n -> do case PromotionFlag p of PromotionFlag IsPromoted -> do Text -> R () txt Text "'" case RdrName -> String forall o. Outputable o => o -> String showOutputable (GenLocated SrcSpan RdrName -> RdrName forall l e. GenLocated l e -> e unLoc Located (IdP GhcPs) GenLocated SrcSpan RdrName n) of Char _ : Char '\'' : String _ -> R () space String _ -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () PromotionFlag NotPromoted -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () GenLocated SrcSpan RdrName -> R () p_rdrName Located (IdP GhcPs) GenLocated SrcSpan RdrName n HsAppTy XAppTy GhcPs NoExtField LHsType GhcPs f LHsType GhcPs x -> do let -- In order to format type applications with multiple parameters -- nicer, traverse the AST to gather the function and all the -- parameters together. gatherArgs :: LHsType pass -> [LHsType pass] -> (LHsType pass, [LHsType pass]) gatherArgs LHsType pass f' [LHsType pass] knownArgs = case LHsType pass f' of L SrcSpan _ (HsAppTy XAppTy pass _ LHsType pass l LHsType pass r) -> LHsType pass -> [LHsType pass] -> (LHsType pass, [LHsType pass]) gatherArgs LHsType pass l (LHsType pass r LHsType pass -> [LHsType pass] -> [LHsType pass] forall a. a -> [a] -> [a] : [LHsType pass] knownArgs) LHsType pass _ -> (LHsType pass f', [LHsType pass] knownArgs) (LHsType GhcPs func, HsContext GhcPs args) = LHsType GhcPs -> HsContext GhcPs -> (LHsType GhcPs, HsContext GhcPs) forall pass. LHsType pass -> [LHsType pass] -> (LHsType pass, [LHsType pass]) gatherArgs LHsType GhcPs f [LHsType GhcPs x] [SrcSpan] -> R () -> R () switchLayout (LHsType GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc LHsType GhcPs f SrcSpan -> [SrcSpan] -> [SrcSpan] forall a. a -> [a] -> [a] : (LHsType GhcPs -> SrcSpan) -> HsContext GhcPs -> [SrcSpan] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap LHsType GhcPs -> SrcSpan forall l e. GenLocated l e -> l getLoc HsContext GhcPs args) (R () -> R ()) -> (R () -> R ()) -> R () -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs func HsType GhcPs -> R () p_hsType R () breakpoint R () -> R () inci (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LHsType GhcPs -> R ()) -> HsContext GhcPs -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () breakpoint ((HsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' HsType GhcPs -> R () p_hsType) HsContext GhcPs args HsAppKindTy XAppKindTy GhcPs _ LHsType GhcPs ty LHsType GhcPs kd -> R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do -- The first argument is the location of the "@..." part. Not 100% sure, -- but I think we can ignore it as long as we use 'located' on both the -- type and the kind. LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs ty HsType GhcPs -> R () p_hsType R () breakpoint R () -> R () inci (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do Text -> R () txt Text "@" LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs kd HsType GhcPs -> R () p_hsType HsFunTy XFunTy GhcPs NoExtField HsArrow GhcPs arrow LHsType GhcPs x y :: LHsType GhcPs y@(L SrcSpan _ HsType GhcPs y') -> do LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs x HsType GhcPs -> R () p_hsType R () space case HsArrow GhcPs arrow of HsUnrestrictedArrow IsUnicodeSyntax _ -> Text -> R () txt Text "->" HsLinearArrow IsUnicodeSyntax _ -> Text -> R () txt Text "%1 ->" HsExplicitMult IsUnicodeSyntax _ LHsType GhcPs mult -> do Text -> R () txt Text "%" HsType GhcPs -> R () p_hsTypeR (LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs mult) R () space Text -> R () txt Text "->" R () interArgBreak case HsType GhcPs y' of HsFunTy {} -> HsType GhcPs -> R () p_hsTypeR HsType GhcPs y' HsType GhcPs _ -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs y HsType GhcPs -> R () p_hsTypeR HsListTy XListTy GhcPs NoExtField LHsType GhcPs t -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t (BracketStyle -> R () -> R () brackets BracketStyle N (R () -> R ()) -> (HsType GhcPs -> R ()) -> HsType GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . HsType GhcPs -> R () p_hsType) HsTupleTy XTupleTy GhcPs NoExtField HsTupleSort tsort HsContext GhcPs xs -> let parens' :: R () -> R () parens' = case HsTupleSort tsort of HsTupleSort HsUnboxedTuple -> BracketStyle -> R () -> R () parensHash BracketStyle N HsTupleSort HsBoxedTuple -> BracketStyle -> R () -> R () parens BracketStyle N HsTupleSort HsConstraintTuple -> BracketStyle -> R () -> R () parens BracketStyle N HsTupleSort HsBoxedOrConstraintTuple -> BracketStyle -> R () -> R () parens BracketStyle N in R () -> R () parens' (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LHsType GhcPs -> R ()) -> HsContext GhcPs -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () commaDel (R () -> R () sitcc (R () -> R ()) -> (LHsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' HsType GhcPs -> R () p_hsType) HsContext GhcPs xs HsSumTy XSumTy GhcPs NoExtField HsContext GhcPs xs -> BracketStyle -> R () -> R () parensHash BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LHsType GhcPs -> R ()) -> HsContext GhcPs -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep (Text -> R () txt Text "|" R () -> R () -> R () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> R () breakpoint) (R () -> R () sitcc (R () -> R ()) -> (LHsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' HsType GhcPs -> R () p_hsType) HsContext GhcPs xs HsOpTy XOpTy GhcPs NoExtField LHsType GhcPs x Located (IdP GhcPs) op LHsType GhcPs y -> R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ let opTree :: OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) opTree = OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> GenLocated SrcSpan RdrName -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op OpBranch (LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) tyOpTree LHsType GhcPs x) Located (IdP GhcPs) GenLocated SrcSpan RdrName op (LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) tyOpTree LHsType GhcPs y) in OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> R () p_tyOpTree ((RdrName -> Maybe RdrName) -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) forall op ty. (op -> Maybe RdrName) -> OpTree (Located ty) (Located op) -> OpTree (Located ty) (Located op) reassociateOpTree RdrName -> Maybe RdrName forall a. a -> Maybe a Just OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) opTree) HsParTy XParTy GhcPs NoExtField LHsType GhcPs t -> BracketStyle -> R () -> R () parens BracketStyle N (LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType) HsIParamTy XIParamTy GhcPs NoExtField Located HsIPName n LHsType GhcPs t -> R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do Located HsIPName -> (HsIPName -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located Located HsIPName n HsIPName -> R () forall a. Outputable a => a -> R () atom R () space Text -> R () txt Text "::" R () breakpoint R () -> R () inci (LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType) HsStarTy XStarTy GhcPs NoExtField Bool _ -> Text -> R () txt Text "*" HsKindSig XKindSig GhcPs NoExtField LHsType GhcPs t LHsType GhcPs k -> R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType R () space Text -> R () txt Text "::" R () breakpoint R () -> R () inci (LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs k HsType GhcPs -> R () p_hsType) HsSpliceTy XSpliceTy GhcPs NoExtField HsSplice GhcPs splice -> HsSplice GhcPs -> R () p_hsSplice HsSplice GhcPs splice HsDocTy XDocTy GhcPs NoExtField LHsType GhcPs t LHsDocString str -> case TypeDocStyle docStyle of TypeDocStyle PipeStyle -> do HaddockStyle -> Bool -> LHsDocString -> R () p_hsDocString HaddockStyle Pipe Bool True LHsDocString str LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType TypeDocStyle CaretStyle -> do LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType R () newline HaddockStyle -> Bool -> LHsDocString -> R () p_hsDocString HaddockStyle Caret Bool False LHsDocString str HsBangTy XBangTy GhcPs NoExtField (HsSrcBang SourceText _ SrcUnpackedness u SrcStrictness s) LHsType GhcPs t -> do case SrcUnpackedness u of SrcUnpackedness SrcUnpack -> Text -> R () txt Text "{-# UNPACK #-}" R () -> R () -> R () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> R () space SrcUnpackedness SrcNoUnpack -> Text -> R () txt Text "{-# NOUNPACK #-}" R () -> R () -> R () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> R () space SrcUnpackedness NoSrcUnpack -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () case SrcStrictness s of SrcStrictness SrcLazy -> Text -> R () txt Text "~" SrcStrictness SrcStrict -> Text -> R () txt Text "!" SrcStrictness NoSrcStrict -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs t HsType GhcPs -> R () p_hsType HsRecTy XRecTy GhcPs NoExtField [LConDeclField GhcPs] fields -> [LConDeclField GhcPs] -> R () p_conDeclFields [LConDeclField GhcPs] fields HsExplicitListTy XExplicitListTy GhcPs NoExtField PromotionFlag p HsContext GhcPs xs -> do case PromotionFlag p of PromotionFlag IsPromoted -> Text -> R () txt Text "'" PromotionFlag NotPromoted -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () BracketStyle -> R () -> R () brackets BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do -- If both this list itself and the first element is promoted, -- we need to put a space in between or it fails to parse. case (PromotionFlag p, HsContext GhcPs xs) of (PromotionFlag IsPromoted, L SrcSpan _ HsType GhcPs t : HsContext GhcPs _) | HsType GhcPs -> Bool forall pass. HsType pass -> Bool isPromoted HsType GhcPs t -> R () space (PromotionFlag, HsContext GhcPs) _ -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () R () -> (LHsType GhcPs -> R ()) -> HsContext GhcPs -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () commaDel (R () -> R () sitcc (R () -> R ()) -> (LHsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' HsType GhcPs -> R () p_hsType) HsContext GhcPs xs HsExplicitTupleTy XExplicitTupleTy GhcPs NoExtField HsContext GhcPs xs -> do Text -> R () txt Text "'" BracketStyle -> R () -> R () parens BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do case HsContext GhcPs xs of L SrcSpan _ HsType GhcPs t : HsContext GhcPs _ | HsType GhcPs -> Bool forall pass. HsType pass -> Bool isPromoted HsType GhcPs t -> R () space HsContext GhcPs _ -> () -> R () forall (m :: * -> *) a. Monad m => a -> m a return () R () -> (LHsType GhcPs -> R ()) -> HsContext 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) HsContext GhcPs xs HsTyLit XTyLit GhcPs NoExtField HsTyLit t -> case HsTyLit t of HsStrTy (SourceText String s) FastString _ -> String -> R () p_stringLit String s HsTyLit a -> HsTyLit -> R () forall a. Outputable a => a -> R () atom HsTyLit a HsWildCardTy XWildCardTy GhcPs NoExtField -> Text -> R () txt Text "_" XHsType (NHsCoreTy t) -> Type -> R () forall a. Outputable a => a -> R () atom Type t where isPromoted :: HsType pass -> Bool isPromoted = \case HsAppTy XAppTy pass _ (L SrcSpan _ HsType pass f) GenLocated SrcSpan (HsType pass) _ -> HsType pass -> Bool isPromoted HsType pass f HsTyVar XTyVar pass _ PromotionFlag IsPromoted Located (IdP pass) _ -> Bool True HsExplicitTupleTy {} -> Bool True HsExplicitListTy {} -> Bool True HsType pass _ -> Bool False interArgBreak :: R () interArgBreak = if Bool multilineArgs then R () newline else R () breakpoint p_hsTypeR :: HsType GhcPs -> R () p_hsTypeR = Bool -> TypeDocStyle -> HsType GhcPs -> R () p_hsType' Bool multilineArgs TypeDocStyle docStyle -- | Return 'True' if at least one argument in 'HsType' has a doc string -- attached to it. hasDocStrings :: HsType GhcPs -> Bool hasDocStrings :: HsType GhcPs -> Bool hasDocStrings = \case HsDocTy {} -> Bool True HsFunTy XFunTy GhcPs _ HsArrow GhcPs _ (L SrcSpan _ HsType GhcPs x) (L SrcSpan _ HsType GhcPs y) -> HsType GhcPs -> Bool hasDocStrings HsType GhcPs x Bool -> Bool -> Bool || HsType GhcPs -> Bool hasDocStrings HsType GhcPs y HsForAllTy XForAllTy GhcPs _ HsForAllTelescope GhcPs _ (L SrcSpan _ HsType GhcPs x) -> HsType GhcPs -> Bool hasDocStrings HsType GhcPs x HsQualTy XQualTy GhcPs _ LHsContext GhcPs _ (L SrcSpan _ HsType GhcPs x) -> HsType GhcPs -> Bool hasDocStrings HsType GhcPs x HsType GhcPs _ -> Bool False p_hsContext :: HsContext GhcPs -> R () p_hsContext :: HsContext GhcPs -> R () p_hsContext = \case [] -> Text -> R () txt Text "()" [LHsType GhcPs x] -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs x HsType GhcPs -> R () p_hsType HsContext GhcPs xs -> BracketStyle -> R () -> R () parens BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LHsType GhcPs -> R ()) -> HsContext GhcPs -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () commaDel (R () -> R () sitcc (R () -> R ()) -> (LHsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsType GhcPs -> R ()) -> LHsType GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' HsType GhcPs -> R () p_hsType) HsContext GhcPs xs class IsInferredTyVarBndr flag where isInferred :: flag -> Bool instance IsInferredTyVarBndr () where isInferred :: () -> Bool isInferred () = Bool False instance IsInferredTyVarBndr Specificity where isInferred :: Specificity -> Bool isInferred = \case Specificity InferredSpec -> Bool True Specificity SpecifiedSpec -> Bool False p_hsTyVarBndr :: IsInferredTyVarBndr flag => HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr :: HsTyVarBndr flag GhcPs -> R () p_hsTyVarBndr = \case UserTyVar XUserTyVar GhcPs NoExtField flag flag Located (IdP GhcPs) x -> (if flag -> Bool forall flag. IsInferredTyVarBndr flag => flag -> Bool isInferred flag flag then BracketStyle -> R () -> R () braces BracketStyle N else R () -> R () forall a. a -> a id) (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ GenLocated SrcSpan RdrName -> R () p_rdrName Located (IdP GhcPs) GenLocated SrcSpan RdrName x KindedTyVar XKindedTyVar GhcPs NoExtField flag flag Located (IdP GhcPs) l LHsType GhcPs k -> (if flag -> Bool forall flag. IsInferredTyVarBndr flag => flag -> Bool isInferred flag flag then BracketStyle -> R () -> R () braces else BracketStyle -> R () -> R () parens) BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do GenLocated SrcSpan RdrName -> (RdrName -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located Located (IdP GhcPs) GenLocated SrcSpan RdrName l RdrName -> R () forall a. Outputable a => a -> R () atom R () space Text -> R () txt Text "::" R () breakpoint R () -> R () inci (LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs k HsType GhcPs -> R () p_hsType) data ForAllVisibility = ForAllInvis | ForAllVis -- | Render several @forall@-ed variables. p_forallBndrs :: Data a => ForAllVisibility -> (a -> R ()) -> [Located a] -> R () p_forallBndrs :: ForAllVisibility -> (a -> R ()) -> [Located a] -> R () p_forallBndrs ForAllVisibility ForAllInvis a -> R () _ [] = Text -> R () txt Text "forall." p_forallBndrs ForAllVisibility ForAllVis a -> R () _ [] = Text -> R () txt Text "forall ->" p_forallBndrs ForAllVisibility vis a -> R () p [Located a] tyvars = [SrcSpan] -> R () -> R () switchLayout (Located a -> SrcSpan forall l e. GenLocated l e -> l getLoc (Located a -> SrcSpan) -> [Located a] -> [SrcSpan] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Located a] tyvars) (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do Text -> R () txt Text "forall" R () breakpoint R () -> R () inci (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (Located a -> R ()) -> [Located a] -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () breakpoint (R () -> R () sitcc (R () -> R ()) -> (Located a -> R ()) -> Located a -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> R ()) -> Located a -> R () forall a. (a -> R ()) -> Located a -> R () located' a -> R () p) [Located a] tyvars case ForAllVisibility vis of ForAllVisibility ForAllInvis -> Text -> R () txt Text "." ForAllVisibility ForAllVis -> R () space R () -> R () -> R () forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Text -> R () txt Text "->" p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields [LConDeclField GhcPs] xs = BracketStyle -> R () -> R () braces BracketStyle N (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LConDeclField GhcPs -> R ()) -> [LConDeclField GhcPs] -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () commaDel (R () -> R () sitcc (R () -> R ()) -> (LConDeclField GhcPs -> R ()) -> LConDeclField GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . (ConDeclField GhcPs -> R ()) -> LConDeclField GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' ConDeclField GhcPs -> R () p_conDeclField) [LConDeclField GhcPs] xs p_conDeclField :: ConDeclField GhcPs -> R () p_conDeclField :: ConDeclField GhcPs -> R () p_conDeclField ConDeclField {[LFieldOcc GhcPs] Maybe LHsDocString XConDeclField GhcPs LHsType GhcPs cd_fld_ext :: forall pass. ConDeclField pass -> XConDeclField pass cd_fld_names :: forall pass. ConDeclField pass -> [LFieldOcc pass] cd_fld_type :: forall pass. ConDeclField pass -> LBangType pass cd_fld_doc :: forall pass. ConDeclField pass -> Maybe LHsDocString cd_fld_doc :: Maybe LHsDocString cd_fld_type :: LHsType GhcPs cd_fld_names :: [LFieldOcc GhcPs] cd_fld_ext :: XConDeclField GhcPs ..} = do (LHsDocString -> R ()) -> Maybe LHsDocString -> R () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> m b) -> t a -> m () mapM_ (HaddockStyle -> Bool -> LHsDocString -> R () p_hsDocString HaddockStyle Pipe Bool True) Maybe LHsDocString cd_fld_doc R () -> R () sitcc (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ R () -> (LFieldOcc GhcPs -> R ()) -> [LFieldOcc GhcPs] -> R () forall a. R () -> (a -> R ()) -> [a] -> R () sep R () commaDel ((FieldOcc GhcPs -> R ()) -> LFieldOcc GhcPs -> R () forall a. (a -> R ()) -> Located a -> R () located' (GenLocated SrcSpan RdrName -> R () p_rdrName (GenLocated SrcSpan RdrName -> R ()) -> (FieldOcc GhcPs -> GenLocated SrcSpan RdrName) -> FieldOcc GhcPs -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . FieldOcc GhcPs -> GenLocated SrcSpan RdrName forall pass. FieldOcc pass -> GenLocated SrcSpan RdrName rdrNameFieldOcc)) [LFieldOcc GhcPs] cd_fld_names R () space Text -> R () txt Text "::" R () breakpoint R () -> R () sitcc (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 $ HsType GhcPs -> R () p_hsType (LHsType GhcPs -> HsType GhcPs forall l e. GenLocated l e -> e unLoc LHsType GhcPs cd_fld_type) tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (Located RdrName) tyOpTree :: LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) tyOpTree (L SrcSpan _ (HsOpTy XOpTy GhcPs NoExtField LHsType GhcPs l Located (IdP GhcPs) op LHsType GhcPs r)) = OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> GenLocated SrcSpan RdrName -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) forall ty op. OpTree ty op -> op -> OpTree ty op -> OpTree ty op OpBranch (LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) tyOpTree LHsType GhcPs l) Located (IdP GhcPs) GenLocated SrcSpan RdrName op (LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) tyOpTree LHsType GhcPs r) tyOpTree LHsType GhcPs n = LHsType GhcPs -> OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) forall ty op. ty -> OpTree ty op OpNode LHsType GhcPs n p_tyOpTree :: OpTree (LHsType GhcPs) (Located RdrName) -> R () p_tyOpTree :: OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> R () p_tyOpTree (OpNode LHsType GhcPs n) = LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs n HsType GhcPs -> R () p_hsType p_tyOpTree (OpBranch OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) l GenLocated SrcSpan RdrName op OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) r) = do [SrcSpan] -> R () -> R () switchLayout [OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> SrcSpan forall a b. OpTree (Located a) b -> SrcSpan opTreeLoc OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) l] (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> R () p_tyOpTree OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) l R () breakpoint R () -> R () inci (R () -> R ()) -> (R () -> R ()) -> R () -> R () forall b c a. (b -> c) -> (a -> b) -> a -> c . [SrcSpan] -> R () -> R () switchLayout [OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> SrcSpan forall a b. OpTree (Located a) b -> SrcSpan opTreeLoc OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) r] (R () -> R ()) -> R () -> R () forall a b. (a -> b) -> a -> b $ do GenLocated SrcSpan RdrName -> R () p_rdrName GenLocated SrcSpan RdrName op R () space OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) -> R () p_tyOpTree OpTree (LHsType GhcPs) (GenLocated SrcSpan RdrName) r p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg :: LHsTypeArg GhcPs -> R () p_lhsTypeArg = \case HsValArg LHsType GhcPs ty -> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs ty HsType GhcPs -> R () p_hsType -- first argument is the SrcSpan of the @, -- but the @ always has to be directly before the type argument HsTypeArg SrcSpan _ LHsType GhcPs ty -> Text -> R () txt Text "@" R () -> R () -> R () forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> LHsType GhcPs -> (HsType GhcPs -> R ()) -> R () forall a. Located a -> (a -> R ()) -> R () located LHsType GhcPs ty HsType GhcPs -> R () p_hsType -- NOTE(amesgen) is this unreachable or just not implemented? HsArgPar SrcSpan _ -> String -> R () forall a. String -> a notImplemented String "HsArgPar" ---------------------------------------------------------------------------- -- Conversion functions tyVarsToTypes :: LHsQTyVars GhcPs -> [LHsType GhcPs] tyVarsToTypes :: LHsQTyVars GhcPs -> HsContext GhcPs tyVarsToTypes HsQTvs {[LHsTyVarBndr () GhcPs] XHsQTvs GhcPs hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass] hsq_explicit :: [LHsTyVarBndr () GhcPs] hsq_ext :: XHsQTvs GhcPs ..} = (HsTyVarBndr () GhcPs -> HsType GhcPs) -> LHsTyVarBndr () GhcPs -> LHsType GhcPs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HsTyVarBndr () GhcPs -> HsType GhcPs tyVarToType (LHsTyVarBndr () GhcPs -> LHsType GhcPs) -> [LHsTyVarBndr () GhcPs] -> HsContext GhcPs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [LHsTyVarBndr () GhcPs] hsq_explicit tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs tyVarToType :: HsTyVarBndr () GhcPs -> HsType GhcPs tyVarToType = \case UserTyVar XUserTyVar GhcPs NoExtField () Located (IdP GhcPs) tvar -> XTyVar GhcPs -> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs forall pass. XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass HsTyVar NoExtField XTyVar GhcPs NoExtField PromotionFlag NotPromoted Located (IdP GhcPs) tvar KindedTyVar XKindedTyVar GhcPs NoExtField () Located (IdP GhcPs) tvar LHsType GhcPs kind -> -- Note: we always add parentheses because for whatever reason GHC does -- not use HsParTy for left-hand sides of declarations. Please see -- <https://gitlab.haskell.org/ghc/ghc/issues/17404>. This is fine as -- long as 'tyVarToType' does not get applied to right-hand sides of -- declarations. XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs forall pass. XParTy pass -> LHsType pass -> HsType pass HsParTy NoExtField XParTy GhcPs NoExtField (LHsType GhcPs -> HsType GhcPs) -> (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> HsType GhcPs forall b c a. (b -> c) -> (a -> b) -> a -> c . HsType GhcPs -> LHsType GhcPs forall e. e -> Located e noLoc (HsType GhcPs -> HsType GhcPs) -> HsType GhcPs -> HsType GhcPs forall a b. (a -> b) -> a -> b $ XKindSig GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs forall pass. XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass HsKindSig NoExtField XKindSig GhcPs NoExtField (HsType GhcPs -> LHsType GhcPs forall e. e -> Located e noLoc (XTyVar GhcPs -> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs forall pass. XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass HsTyVar NoExtField XTyVar GhcPs NoExtField PromotionFlag NotPromoted Located (IdP GhcPs) tvar)) LHsType GhcPs kind tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs tyVarsToTyPats :: LHsQTyVars GhcPs -> HsTyPats GhcPs tyVarsToTyPats HsQTvs {[LHsTyVarBndr () GhcPs] XHsQTvs GhcPs hsq_explicit :: [LHsTyVarBndr () GhcPs] hsq_ext :: XHsQTvs GhcPs hsq_ext :: forall pass. LHsQTyVars pass -> XHsQTvs pass hsq_explicit :: forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass] ..} = LHsType GhcPs -> LHsTypeArg GhcPs forall tm ty. tm -> HsArg tm ty HsValArg (LHsType GhcPs -> LHsTypeArg GhcPs) -> (LHsTyVarBndr () GhcPs -> LHsType GhcPs) -> LHsTyVarBndr () GhcPs -> LHsTypeArg GhcPs forall b c a. (b -> c) -> (a -> b) -> a -> c . (HsTyVarBndr () GhcPs -> HsType GhcPs) -> LHsTyVarBndr () GhcPs -> LHsType GhcPs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HsTyVarBndr () GhcPs -> HsType GhcPs tyVarToType (LHsTyVarBndr () GhcPs -> LHsTypeArg GhcPs) -> [LHsTyVarBndr () GhcPs] -> HsTyPats GhcPs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [LHsTyVarBndr () GhcPs] hsq_explicit