module HsTypes (
HsType(..), LHsType, HsKind, LHsKind,
HsTyOp,LHsTyOp,
HsTyVarBndr(..), LHsTyVarBndr,
LHsTyVarBndrs(..),
HsWithBndrs(..),
HsTupleSort(..), HsExplicitFlag(..),
HsContext, LHsContext,
HsQuasiQuote(..),
HsTyWrapper(..),
HsTyLit(..),
HsIPName(..), hsIPNameFS,
LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy,
mkHsForAllTy,
flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy,
flattenHsForAllTyKeepAnns,
hsExplicitTvs,
hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitLHsInstDeclTy_maybe,
splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType,
splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
isWildcardTy, isNamedWildcardTy,
pprParendHsType, pprHsForAll, pprHsForAllExtra,
pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
) where
import HsExpr ( HsSplice, pprUntypedSplice )
import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..), HsSrcBang, HsImplBang )
import TysPrim( funTyConName )
import Type
import HsDoc
import BasicTypes
import SrcLoc
import StaticFlags
import Outputable
import FastString
import Lexer ( AddAnn, mkParensApiAnn )
import Maybes( isJust )
import Data.Data hiding ( Fixity )
import Data.Maybe ( fromMaybe )
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid hiding ((<>))
#endif
data HsQuasiQuote id = HsQuasiQuote
id
SrcSpan
FastString
deriving (Data, Typeable)
instance OutputableBndr id => Outputable (HsQuasiQuote id) where
ppr = ppr_qq
ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
ppr_qq (HsQuasiQuote quoter _ quote) =
char '[' <> ppr quoter <> ptext (sLit "|") <>
ppr quote <> ptext (sLit "|]")
type LBangType name = Located (BangType name)
type BangType name = HsType name
getBangType :: LHsType a -> LHsType a
getBangType (L _ (HsBangTy _ ty)) = ty
getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy s _)) = s
getBangStrictness _ = HsNoBang
type LHsContext name = Located (HsContext name)
type HsContext name = [LHsType name]
type LHsType name = Located (HsType name)
type HsKind name = HsType name
type LHsKind name = Located (HsKind name)
type LHsTyVarBndr name = Located (HsTyVarBndr name)
data LHsTyVarBndrs name
= HsQTvs { hsq_kvs :: [Name]
, hsq_tvs :: [LHsTyVarBndr name]
}
deriving( Typeable )
deriving instance (DataId name) => Data (LHsTyVarBndrs name)
mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName
mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs }
emptyHsQTvs :: LHsTyVarBndrs name
emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] }
hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
hsQTvBndrs = hsq_tvs
instance Monoid (LHsTyVarBndrs name) where
mempty = emptyHsQTvs
mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2)
= HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2)
data HsWithBndrs name thing
= HsWB { hswb_cts :: thing
, hswb_kvs :: PostRn name [Name]
, hswb_tvs :: PostRn name [Name]
, hswb_wcs :: PostRn name [Name]
}
deriving (Typeable)
deriving instance (Data name, Data thing, Data (PostRn name [Name]))
=> Data (HsWithBndrs name thing)
mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing
mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder
, hswb_tvs = PlaceHolder
, hswb_wcs = PlaceHolder }
newtype HsIPName = HsIPName FastString
deriving( Eq, Data, Typeable )
hsIPNameFS :: HsIPName -> FastString
hsIPNameFS (HsIPName n) = n
instance Outputable HsIPName where
ppr (HsIPName n) = char '?' <> ftext n
instance OutputableBndr HsIPName where
pprBndr _ n = ppr n
pprInfixOcc n = ppr n
pprPrefixOcc n = ppr n
data HsTyVarBndr name
= UserTyVar
name
| KindedTyVar
(Located name)
(LHsKind name)
deriving (Typeable)
deriving instance (DataId name) => Data (HsTyVarBndr name)
isHsKindedTyVar :: HsTyVarBndr name -> Bool
isHsKindedTyVar (UserTyVar {}) = False
isHsKindedTyVar (KindedTyVar {}) = True
hsTvbAllKinded :: LHsTyVarBndrs name -> Bool
hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs
data HsType name
= HsForAllTy HsExplicitFlag
(Maybe SrcSpan)
(LHsTyVarBndrs name)
(LHsContext name)
(LHsType name)
| HsTyVar name
| HsAppTy (LHsType name)
(LHsType name)
| HsFunTy (LHsType name)
(LHsType name)
| HsListTy (LHsType name)
| HsPArrTy (LHsType name)
| HsTupleTy HsTupleSort
[LHsType name]
| HsOpTy (LHsType name) (LHsTyOp name) (LHsType name)
| HsParTy (LHsType name)
| HsIParamTy HsIPName
(LHsType name)
| HsEqTy (LHsType name)
(LHsType name)
| HsKindSig (LHsType name)
(LHsKind name)
| HsQuasiQuoteTy (HsQuasiQuote name)
| HsSpliceTy (HsSplice name)
(PostTc name Kind)
| HsDocTy (LHsType name) LHsDocString
| HsBangTy HsSrcBang (LHsType name)
| HsRecTy [LConDeclField name]
| HsCoreTy Type
| HsExplicitListTy
(PostTc name Kind)
[LHsType name]
| HsExplicitTupleTy
[PostTc name Kind]
[LHsType name]
| HsTyLit HsTyLit
| HsWrapTy HsTyWrapper (HsType name)
| HsWildcardTy
| HsNamedWildcardTy name
deriving (Typeable)
deriving instance (DataId name) => Data (HsType name)
data HsTyLit
= HsNumTy SourceText Integer
| HsStrTy SourceText FastString
deriving (Data, Typeable)
data HsTyWrapper
= WpKiApps [Kind]
deriving (Data, Typeable)
type LHsTyOp name = HsTyOp (Located name)
type HsTyOp name = (HsTyWrapper, name)
mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
data HsTupleSort = HsUnboxedTuple
| HsBoxedTuple
| HsConstraintTuple
| HsBoxedOrConstraintTuple
deriving (Data, Typeable)
data HsExplicitFlag = Qualified | Implicit | Explicit deriving (Data, Typeable)
type LConDeclField name = Located (ConDeclField name)
data ConDeclField name
= ConDeclField { cd_fld_names :: [Located name],
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe LHsDocString }
deriving (Typeable)
deriving instance (DataId name) => Data (ConDeclField name)
mkImplicitHsForAllTy :: LHsType RdrName -> HsType RdrName
mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
mkQualifiedHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName
mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty))
= HsForAllTy exp' extra tvs cxt ty
where
exp' = case exp of
Qualified -> Implicit
_ -> exp
mkImplicitHsForAllTy ty = mkHsForAllTy Implicit [] (noLoc []) ty
mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
mkQualifiedHsForAllTy ctxt ty = mkHsForAllTy Qualified [] ctxt ty
mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName
mkHsForAllTy exp tvs (L l []) ty
= HsForAllTy exp Nothing (mkHsQTvs tvs) (L l []) ty
mkHsForAllTy exp tvs ctxt ty
= HsForAllTy exp extra (mkHsQTvs tvs) cleanCtxt ty
where
(cleanCtxt, extra)
| (L l HsWildcardTy) <- ignoreParens (last (unLoc ctxt)) = (init `fmap` ctxt, Just l)
| otherwise = (ctxt, Nothing)
ignoreParens (L _ (HsParTy ty)) = ty
ignoreParens ty = ty
flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name
flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty)
flattenTopLevelHsForAllTy :: HsType name -> HsType name
flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty)
= snd $ mk_forall_ty [] l exp extra tvs ty
flattenTopLevelHsForAllTy ty = ty
flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name)
flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty)
= mk_forall_ty [] l exp extra tvs ty
flattenHsForAllTyKeepAnns ty = ([],ty)
mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan
-> LHsTyVarBndrs name
-> LHsType name -> ([AddAnn],HsType name)
mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty))
= (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra)
(tvs1 `mappend` qtvs2) ctxt ty)
where
mergeExtra (Just s) _ = Just s
mergeExtra _ e = e
mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty))
= mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty
mk_forall_ty ann l exp extra tvs ty
= (ann,HsForAllTy exp extra tvs (L l []) ty)
plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag
Qualified `plus` Qualified = Qualified
Explicit `plus` _ = Explicit
_ `plus` Explicit = Explicit
_ `plus` _ = Implicit
hsExplicitTvs :: LHsType Name -> [Name]
hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs
hsExplicitTvs _ = []
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (UserTyVar n) = n
hsTyVarName (KindedTyVar (L _ n) _) = n
hsLTyVarName :: LHsTyVarBndr name -> name
hsLTyVarName = hsTyVarName . unLoc
hsLTyVarNames :: LHsTyVarBndrs name -> [name]
hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name]
hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
= kvs ++ map hsLTyVarName tvs
hsLTyVarLocName :: LHsTyVarBndr name -> Located name
hsLTyVarLocName = fmap hsTyVarName
hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
isWildcardTy :: HsType a -> Bool
isWildcardTy HsWildcardTy = True
isWildcardTy _ = False
isNamedWildcardTy :: HsType a -> Bool
isNamedWildcardTy (HsNamedWildcardTy _) = True
isNamedWildcardTy _ = False
splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as
splitHsAppTys f as = (f,as)
hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n])
hsTyGetAppHead_maybe = go []
where
go tys (L _ (HsTyVar n)) = Just (n, tys)
go tys (L _ (HsAppTy l r)) = go (r : tys) l
go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys)
go tys (L _ (HsParTy t)) = go tys t
go tys (L _ (HsKindSig t _)) = go tys t
go _ _ = Nothing
mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
mkHsAppTys fun_ty (arg_ty:arg_tys)
= foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
where
mk_app fun arg = HsAppTy (noLoc fun) arg
splitLHsInstDeclTy_maybe
:: LHsType name
-> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
splitLHsInstDeclTy_maybe inst_ty = do
let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
(cls, tys) <- splitLHsClassTy_maybe ty
return (tvs, cxt, cls, tys)
splitLHsForAllTy
:: LHsType name
-> (LHsTyVarBndrs name, HsContext name, LHsType name)
splitLHsForAllTy poly_ty
= case unLoc poly_ty of
HsParTy ty -> splitLHsForAllTy ty
HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty)
_ -> (emptyHsQTvs, [], poly_ty)
splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
splitLHsClassTy_maybe ty
= checkl ty []
where
checkl (L l ty) args = case ty of
HsTyVar t -> Just (L l t, args)
HsAppTy l r -> checkl l (r:args)
HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args)
HsParTy t -> checkl t args
HsKindSig ty _ -> checkl ty args
_ -> Nothing
splitHsFunType :: LHsType Name -> ([LHsType Name], LHsType Name)
splitHsFunType (L _ (HsParTy ty))
= splitHsFunType ty
splitHsFunType (L _ (HsFunTy x y))
| (args, res) <- splitHsFunType y
= (x:args, res)
splitHsFunType orig_ty@(L _ (HsAppTy t1 t2))
= go t1 [t2]
where
go (L _ (HsTyVar fn)) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
go (L _ (HsAppTy t1 t2)) tys = go t1 (t2:tys)
go (L _ (HsParTy ty)) tys = go ty tys
go _ _ = ([], orig_ty)
splitHsFunType other = ([], other)
instance (OutputableBndr name) => Outputable (HsType name) where
ppr ty = pprHsType ty
instance Outputable HsTyLit where
ppr = ppr_tylit
instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs })
= sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ]
instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
ppr (UserTyVar n) = ppr n
ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k]
instance (Outputable thing) => Outputable (HsWithBndrs name thing) where
ppr (HsWB { hswb_cts = ty }) = ppr ty
pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAll exp = pprHsForAllExtra exp Nothing
pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc
pprHsForAllExtra exp extra qtvs cxt
| show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt)
| otherwise = pprHsContextExtra show_extra (unLoc cxt)
where
show_extra = isJust extra
show_forall = opt_PprStyle_Debug
|| (not (null (hsQTvBndrs qtvs)) && is_explicit)
is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False}
forall_part = forAllLit <+> ppr qtvs <> dot
pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
pprHsContextNoArrow :: (OutputableBndr name) => HsContext name -> SDoc
pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe
pprHsContextMaybe :: (OutputableBndr name) => HsContext name -> Maybe SDoc
pprHsContextMaybe [] = Nothing
pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred
pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt)
pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc
pprHsContextExtra False = pprHsContext
pprHsContextExtra True
= \ctxt -> case ctxt of
[] -> char '_' <+> darrow
_ -> parens (sep (punctuate comma ctxt')) <+> darrow
where ctxt' = map ppr ctxt ++ [char '_']
pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc
pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,
cd_fld_doc = doc }))
= ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
ppr_names [n] = ppr n
ppr_names ns = sep (punctuate comma (map ppr ns))
pprHsType, pprParendHsType :: (OutputableBndr name) => HsType name -> SDoc
pprHsType ty = getPprStyle $ \sty -> ppr_mono_ty TopPrec (prepare sty ty)
pprParendHsType ty = ppr_mono_ty TyConPrec ty
prepare :: PprStyle -> HsType name -> HsType name
prepare sty (HsParTy ty) = prepare sty (unLoc ty)
prepare _ ty = ty
ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc
ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty)
ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc
ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty)
= maybeParen ctxt_prec FunPrec $
sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty]
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name
ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys)
where std_con = case con of
HsUnboxedTuple -> UnboxedTuple
_ -> BoxedTuple
ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty TopPrec ty <+> dcolon <+> ppr kind)
ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsSpliceTy s _) = pprUntypedSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty _ HsWildcardTy = char '_'
ppr_mono_ty _ (HsNamedWildcardTy name) = ppr name
ppr_mono_ty ctxt_prec (HsWrapTy (WpKiApps _kis) ty)
= ppr_mono_ty ctxt_prec ty
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
= maybeParen ctxt_prec TyOpPrec $
ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec TyConPrec $
hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty]
ppr_mono_ty ctxt_prec (HsOpTy ty1 (_wrapper, L _ op) ty2)
= maybeParen ctxt_prec TyOpPrec $
sep [ ppr_mono_lty TyOpPrec ty1
, sep [pprInfixOcc op, ppr_mono_lty TyOpPrec ty2 ] ]
ppr_mono_ty _ (HsParTy ty)
= parens (ppr_mono_lty TopPrec ty)
ppr_mono_ty ctxt_prec (HsDocTy ty doc)
= maybeParen ctxt_prec TyOpPrec $
ppr_mono_lty TyOpPrec ty <+> ppr (unLoc doc)
ppr_fun_ty :: (OutputableBndr name) => TyPrec -> LHsType name -> LHsType name -> SDoc
ppr_fun_ty ctxt_prec ty1 ty2
= let p1 = ppr_mono_lty FunPrec ty1
p2 = ppr_mono_lty TopPrec ty2
in
maybeParen ctxt_prec FunPrec $
sep [p1, ptext (sLit "->") <+> p2]
ppr_tylit :: HsTyLit -> SDoc
ppr_tylit (HsNumTy _ i) = integer i
ppr_tylit (HsStrTy _ s) = text (show s)