{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
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
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
R ()
space
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
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
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 (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ R () -> R ()
sitcc (R () -> R ()) -> R () -> R ()
forall a b. (a -> b) -> a -> b
$ 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
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
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 ()) -> 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
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
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
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
HsArgPar SrcSpan
_ -> String -> R ()
forall a. String -> a
notImplemented String
"HsArgPar"
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 ->
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