Commit 17bd1635 authored by My Nguyen's avatar My Nguyen Committed by Richard Eisenberg

Visible kind application

Summary:
This patch implements visible kind application (GHC Proposal 15/#12045), as well as #15360 and #15362.
It also refactors unnamed wildcard handling, and requires that type equations in type families in Template Haskell be
written with full type on lhs. PartialTypeSignatures are on and warnings are off automatically with visible kind
application, just like in term-level.

There are a few remaining issues with this patch, as documented in
ticket #16082.

Includes a submodule update for Haddock.

Test Plan: Tests T12045a/b/c/TH1/TH2, T15362, T15592a

Reviewers: simonpj, goldfire, bgamari, alanz, RyanGlScott, Iceland_jack

Subscribers: ningning, Iceland_jack, RyanGlScott, int-index, rwbarton, mpickering, carter

GHC Trac Issues: `#12045`, `#15362`, `#15592`, `#15788`, `#15793`, `#15795`, `#15797`, `#15799`, `#15801`, `#15807`, `#15816`

Differential Revision: https://phabricator.haskell.org/D5229
parent 6e4e6376
......@@ -352,7 +352,7 @@ repRoleD _ = panic "repRoleD"
repDataDefn :: Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
-- the repTyClD case
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
(Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
-- the repDataFamInstD case
-> HsDataDefn GhcRn
-> DsM (Core TH.DecQ)
......@@ -465,18 +465,28 @@ repAssocTyFamDefaults = mapM rep_deflt
rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
, feqn_bndrs = bndrs
, feqn_pats = tys
, feqn_fixity = fixity
, feqn_rhs = rhs }))
= addTyClTyVarBinds tys $ \ _ ->
do { tc1 <- lookupLOcc tc
; no_bndrs <- ASSERT( isNothing bndrs )
coreNothingList tyVarBndrQTyConName
; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
; tys2 <- coreList typeQTyConName tys1
; lhs <- case fixity of
Prefix -> do { head_ty <- repNamedTyCon tc1
; repTapps head_ty tys1 }
Infix -> do { (t1:t2:args) <- checkTys tys1
; head_ty <- repTInfix t1 tc1 t2
; repTapps head_ty args }
; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
; repTySynInst tc1 eqn1 }
; eqn1 <- repTySynEqn no_bndrs lhs rhs1
; repTySynInst eqn1 }
rep_deflt _ = panic "repAssocTyFamDefaults"
checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]
checkTys tys@(_:_:_) = return tys
checkTys _ = panic "repAssocTyFamDefaults:checkTys"
-------------------------
-- represent fundeps
--
......@@ -547,18 +557,19 @@ repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
repStandaloneDerivD _ = panic "repStandaloneDerivD"
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
= do { let tc_name = tyFamInstDeclLName decl
; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; eqn1 <- repTyFamEqn eqn
; repTySynInst tc eqn1 }
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
= do { eqn1 <- repTyFamEqn eqn
; repTySynInst eqn1 }
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_bndrs = mb_bndrs
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_bndrs = mb_bndrs
, feqn_pats = tys
, feqn_fixity = fixity
, feqn_rhs = rhs }})
= do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
, hsq_explicit = fromMaybe [] mb_bndrs }
......@@ -566,21 +577,39 @@ repTyFamEqn (HsIB { hsib_ext = var_names
do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
repTyVarBndr
mb_bndrs
; tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
; rhs1 <- repLTy rhs
; repTySynEqn mb_bndrs1 tys2 rhs1 } }
; repTySynEqn mb_bndrs1 tys1 rhs1 } }
where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _:HsValArg _:_) = return tys
checkTys _ = panic "repTyFamEqn:checkTys"
repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
; ty' <- repLTy ty
; repTyArgs (repTapp f' ty') as }
repTyArgs f (HsTypeArg ki : as) = do { f' <- f
; ki' <- repLTy ki
; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsArgPar _ : as) = repTyArgs f as
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_bndrs = mb_bndrs
, feqn_pats = tys
, feqn_fixity = fixity
, feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
......@@ -589,8 +618,18 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn =
do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
repTyVarBndr
mb_bndrs
; tys1 <- repList typeQTyConName repLTy tys
; tys1 <- case fixity of
Prefix -> repTyArgs (repNamedTyCon tc) tys
Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
; t1' <- repLTy t1
; t2' <- repLTy t2
; repTyArgs (repTInfix t1' tc t2') args }
; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
checkTys tys@(HsValArg _: HsValArg _: _) = return tys
checkTys _ = panic "repDataFamInstD:checkTys"
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
= panic "repDataFamInstD"
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
......@@ -1136,6 +1175,10 @@ repTy (HsAppTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
repTapp f1 a1
repTy (HsAppKindTy _ ty ki) = do
ty1 <- repLTy ty
ki1 <- repLTy ki
repTappKind ty1 ki1
repTy (HsFunTy _ f a) = do
f1 <- repLTy f
a1 <- repLTy a
......@@ -1174,7 +1217,7 @@ repTy (HsExplicitTupleTy _ tys) = do
repTy (HsTyLit _ lit) = do
lit' <- repTyLit lit
repTLit lit'
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy (HsWildCardTy _) = repTWildCard
repTy (HsIParamTy _ n t) = do
n' <- rep_implicit_param_name (unLoc n)
t' <- repLTy t
......@@ -2191,26 +2234,26 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
(Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
-> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
-> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC cons) (MkC derivs)
= rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
(MkC derivs)
= rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
repNewtype :: Core TH.CxtQ -> Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
(Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
-> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
-> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC con) (MkC derivs)
= rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Core TH.TypeQ -> DsM (Core TH.DecQ)
......@@ -2309,9 +2352,9 @@ repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phas
repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
repTySynInst (MkC nm) (MkC eqn)
= rep2 tySynInstDName [nm, eqn]
repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
repTySynInst (MkC eqn)
= rep2 tySynInstDName [eqn]
repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
......@@ -2336,7 +2379,7 @@ repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
= rep2 tySynEqnName [mb_bndrs, lhs, rhs]
......@@ -2429,6 +2472,9 @@ repTvar (MkC s) = rep2 varTName [s]
repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
repTapps f [] = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
......@@ -2467,6 +2513,10 @@ repTConstraint = rep2 constraintKName []
repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
repNamedTyCon (MkC s) = rep2 conTName [s]
repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
-> DsM (Core TH.TypeQ)
repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = do dflags <- getDynFlags
......
......@@ -328,6 +328,10 @@ instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
[loc a, loc tvs, loc b, loc c]
loc _ = noSrcSpan
instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
loc (HsValArg tm) = loc tm
loc (HsTypeArg ty) = loc ty
loc (HsArgPar sp) = sp
instance HasLoc (HsDataDefn GhcRn) where
loc def@(HsDataDefn{}) = loc $ dd_cons def
......@@ -1339,6 +1343,10 @@ instance ToHie (TScoped (LHsType GhcRn)) where
[ toHie a
, toHie b
]
HsAppKindTy _ ty ki ->
[ toHie ty
, toHie $ TS (ResolvedScopes []) ki
]
HsFunTy _ a b ->
[ toHie a
, toHie b
......@@ -1387,14 +1395,14 @@ instance ToHie (TScoped (LHsType GhcRn)) where
[ toHie tys
]
HsTyLit _ _ -> []
HsWildCardTy e ->
[ toHie e
]
HsWildCardTy _ -> []
HsStarTy _ _ -> []
XHsType _ -> []
instance ToHie HsWildCardInfo where
toHie (AnonWildCard name) = toHie $ C Use name
instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsValArg tm) = toHie tm
toHie (HsTypeArg ty) = toHie ty
toHie (HsArgPar sp) = pure $ locOnly sp
instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
......
......@@ -40,7 +40,7 @@ import Outputable
import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap, (<=<) )
import Control.Monad( unless, liftM, ap )
import Data.Maybe( catMaybes, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
......@@ -296,8 +296,8 @@ cvtDec (DataFamilyD tc tvs kind)
; returnJustL $ TyClD noExt $ FamDecl noExt $
FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
......@@ -317,8 +317,8 @@ cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
......@@ -337,9 +337,8 @@ cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
; (dL->L _ eqn') <- cvtTySynEqn tc' eqn
cvtDec (TySynInstD eqn)
= do { (dL->L _ eqn') <- cvtTySynEqn eqn
; returnJustL $ InstD noExt $ TyFamInstD
{ tfid_ext = noExt
, tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
......@@ -352,7 +351,7 @@ cvtDec (OpenTypeFamilyD head)
cvtDec (ClosedTypeFamilyD head eqns)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; eqns' <- mapM (cvtTySynEqn tc') eqns
; eqns' <- mapM cvtTySynEqn eqns
; returnJustL $ TyClD noExt $ FamDecl noExt $
FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
result' injectivity' }
......@@ -412,18 +411,35 @@ cvtDec (TH.ImplicitParamBindD _ _)
= failWith (text "Implicit parameter binding only allowed in let or where")
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn mb_bndrs lhs rhs)
= do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
; lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_bndrs = mb_bndrs'
, feqn_pats = lhs'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
= do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
; (head_ty, args) <- split_ty_app lhs
; case head_ty of
ConT nm -> do { nm' <- tconNameL nm
; rhs' <- cvtType rhs
; args' <- mapM wrap_tyargs args
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_ext = noExt
, feqn_tycon = nm'
, feqn_bndrs = mb_bndrs'
, feqn_pats = args'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
InfixT t1 nm t2 -> do { nm' <- tconNameL nm
; args' <- mapM cvtType [t1,t2]
; rhs' <- cvtType rhs
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_ext = noExt
, feqn_tycon = nm'
, feqn_bndrs = mb_bndrs'
, feqn_pats =
(map HsValArg args') ++ args
, feqn_fixity = Hs.Infix
, feqn_rhs = rhs' } }
_ -> failWith $ text "Invalid type family instance LHS:"
<+> text (show lhs)
}
----------------
cvt_ci_decs :: MsgDoc -> [TH.Dec]
......@@ -458,17 +474,25 @@ cvt_tycl_hdr cxt tc tvs
; return (cxt', tc', tvs')
}
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type]
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
-> CvtM ( LHsContext GhcPs
, Located RdrName
, Maybe [LHsTyVarBndr GhcPs]
, HsTyPats GhcPs)
cvt_tyinst_hdr cxt tc bndrs tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
cvt_datainst_hdr cxt bndrs tys
= do { cxt' <- cvtContext cxt
; bndrs' <- traverse (mapM cvt_tv) bndrs
; tys' <- mapM (wrap_apps <=< cvtType) tys
; return (cxt', tc', bndrs', tys') }
; (head_ty, args) <- split_ty_app tys
; case head_ty of
ConT nm -> do { nm' <- tconNameL nm
; args' <- mapM wrap_tyargs args
; return (cxt', nm', bndrs', args') }
InfixT t1 nm t2 -> do { nm' <- tconNameL nm
; args' <- mapM cvtType [t1,t2]
; return (cxt', nm', bndrs',
((map HsValArg args') ++ args)) }
_ -> failWith $ text "Invalid type instance header:"
<+> text (show tys) }
----------------
cvt_tyfam_head :: TypeFamilyHead
......@@ -1299,54 +1323,67 @@ cvtType = cvtTypeKind "type"
cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
cvtTypeKind ty_str ty
= do { (head_ty, tys') <- split_ty_app ty
; let m_normals = mapM extract_normal tys'
where extract_normal (HsValArg ty) = Just ty
extract_normal _ = Nothing
; case head_ty of
TupleT n
| tys' `lengthIs` n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy noExt
HsBoxedOrConstraintTuple tys')
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
-> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> if n==1 then return (head normals) -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy noExt
HsBoxedOrConstraintTuple normals)
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
-> mk_apps
(HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
tys'
UnboxedTupleT n
| tys' `lengthIs` n -- Saturated
-> returnL (HsTupleTy noExt HsUnboxedTuple tys')
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsTupleTy noExt HsUnboxedTuple normals)
| otherwise
-> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
-> mk_apps
(HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))
tys'
UnboxedSumT n
| n < 2
-> failWith $
vcat [ text "Illegal sum arity:" <+> text (show n)
, nest 2 $
text "Sums must have an arity of at least 2" ]
| tys' `lengthIs` n -- Saturated
-> returnL (HsSumTy noExt tys')
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsSumTy noExt normals)
| otherwise
-> mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName (sumTyCon n))))
tys'
-> mk_apps
(HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))
tys'
ArrowT
| [x',y'] <- tys' -> do
| Just normals <- m_normals
, [x',y'] <- normals -> do
x'' <- case unLoc x' of
HsFunTy{} -> returnL (HsParTy noExt x')
HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
HsQualTy{} -> returnL (HsParTy noExt x') -- #15324
_ -> return x'
returnL (HsFunTy noExt x'' y')
| otherwise ->
mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName funTyCon)))
tys'
| otherwise
-> mk_apps
(HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
tys'
ListT
| [x'] <- tys' -> returnL (HsListTy noExt x')
| otherwise ->
mk_apps (HsTyVar noExt NotPromoted
(noLoc (getRdrName listTyCon)))
tys'
| Just normals <- m_normals
, [x'] <- normals -> do
returnL (HsListTy noExt x')
| otherwise
-> mk_apps
(HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))
tys'
VarT nm -> do { nm' <- tNameL nm
; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
ConT nm -> do { nm' <- tconName nm
......@@ -1387,15 +1424,16 @@ cvtTypeKind ty_str ty
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
; mk_apps (HsTyVar noExt NotPromoted (noLoc s'))
(t1' : t2' : tys')
; mk_apps
(HsTyVar noExt NotPromoted (noLoc s'))
([HsValArg t1', HsValArg t2'] ++ tys')
}
UInfixT t1 s t2
-> do { t2' <- cvtType t2
; t <- cvtOpAppT t1 s t2' -- Note [Converting UInfix]
; t <- cvtOpAppT t1 s t2'
; mk_apps (unLoc t) tys'
}
} -- Note [Converting UInfix]
ParensT t
-> do { t' <- cvtType t
......@@ -1403,45 +1441,48 @@ cvtTypeKind ty_str ty
}
PromotedT nm -> do { nm' <- cName nm
; let hs_ty = HsTyVar noExt IsPromoted (noLoc nm')
; mk_apps hs_ty tys' }
; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))
tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| m == n -- Saturated
-> returnL (HsExplicitTupleTy noExt tys')
| otherwise
-> mk_apps (HsTyVar noExt IsPromoted
(noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
where
m = length tys'
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| Just normals <- m_normals
, normals `lengthIs` n -- Saturated
-> returnL (HsExplicitTupleTy noExt normals)
| otherwise
-> mk_apps
(HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))
tys'
PromotedNilT
-> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'