diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/prelude/THNames.hs | 11 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.hs | 22 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcDerivUtils.hs | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcExpr.hs | 14 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenDeriv.hs | 81 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 9 |
7 files changed, 61 insertions, 88 deletions
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 140b3df6f8..58f9af770d 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -27,7 +27,7 @@ templateHaskellNames :: [Name] -- Should stay in sync with the import list of DsMeta templateHaskellNames = [ - returnQName, bindQName, sequenceQName, newNameName, liftName, + returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, @@ -206,7 +206,7 @@ overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName, - unsafeTExpCoerceName :: Name + unsafeTExpCoerceName, liftTypedName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey @@ -222,6 +222,7 @@ mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey unTypeName = thFun (fsLit "unType") unTypeIdKey unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey +liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey -------------------- TH.Lib ----------------------- @@ -726,7 +727,7 @@ incoherentDataConKey = mkPreludeDataConUnique 212 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey, - unsafeTExpCoerceIdKey :: Unique + unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202 @@ -741,6 +742,7 @@ mkNameSIdKey = mkPreludeMiscIdUnique 210 unTypeIdKey = mkPreludeMiscIdUnique 211 unTypeQIdKey = mkPreludeMiscIdUnique 212 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213 +liftTypedIdKey = mkPreludeMiscIdUnique 214 -- data Lit = ... @@ -1078,8 +1080,9 @@ viaStrategyIdKey = mkPreludeDataConUnique 497 ************************************************************************ -} -lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName +lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName lift_RDR = nameRdrName liftName +liftTyped_RDR = nameRdrName liftTypedName mkNameG_dRDR = nameRdrName mkNameG_dName mkNameG_vRDR = nameRdrName mkNameG_vName diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 89e5569c1e..daadf57313 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -78,24 +78,30 @@ import Control.Monad( unless ) ************************************************************************ -} -newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId) --- Used when Name is the wired-in name for a wired-in class method, +newMethodFromName + :: CtOrigin -- ^ why do we need this? + -> Name -- ^ name of the method + -> [TcRhoType] -- ^ types with which to instantiate the class + -> TcM (HsExpr GhcTcId) +-- ^ Used when 'Name' is the wired-in name for a wired-in class method, -- so the caller knows its type for sure, which should be of form --- forall a. C a => <blah> --- newMethodFromName is supposed to instantiate just the outer +-- +-- > forall a. C a => <blah> +-- +-- 'newMethodFromName' is supposed to instantiate just the outer -- type variable and constraint -newMethodFromName origin name inst_ty +newMethodFromName origin name ty_args = do { id <- tcLookupId name -- Use tcLookupId not tcLookupGlobalId; the method is almost -- always a class op, but with -XRebindableSyntax GHC is -- meant to find whatever thing is in scope, and that may -- be an ordinary function. - ; let ty = piResultTy (idType id) inst_ty + ; let ty = piResultTys (idType id) ty_args (theta, _caller_knows_this) = tcSplitPhiTy ty ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) - instCall origin [inst_ty] theta + instCall origin ty_args theta ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) } @@ -607,7 +613,7 @@ tcSyntaxName :: CtOrigin tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) | std_nm == user_nm - = do rhs <- newMethodFromName orig std_nm ty + = do rhs <- newMethodFromName orig std_nm [ty] return (std_nm, rhs) tcSyntaxName orig ty (std_nm, user_nm_expr) = do diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 826939d389..b7c1478da3 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -335,6 +335,8 @@ renameDeriv is_boot inst_infos bagBinds -- (See Note [Newtype-deriving instances] in TcGenDeriv) unsetXOptM LangExt.RebindableSyntax $ -- See Note [Avoid RebindableSyntax when deriving] + setXOptM LangExt.TemplateHaskellQuotes $ + -- DeriveLift makes uses of quotes do { -- Bring the extra deriving stuff into scope -- before renaming the instances themselves diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs index cb5f6da02d..e7c2451246 100644 --- a/compiler/typecheck/TcDerivUtils.hs +++ b/compiler/typecheck/TcDerivUtils.hs @@ -738,8 +738,10 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond` (cond_isProduct `andCond` cond_args cls) cond_args :: Class -> Condition --- For some classes (eg Eq, Ord) we allow unlifted arg types --- by generating specialised code. For others (eg Data) we don't. +-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types +-- by generating specialised code. For others (eg 'Data') we don't. +-- For even others (eg 'Lift'), unlifted types aren't even a special +-- consideration! cond_args cls _ _ rep_tc = case bad_args of [] -> IsValid @@ -748,7 +750,7 @@ cond_args cls _ _ rep_tc where bad_args = [ arg_ty | con <- tyConDataCons rep_tc , arg_ty <- dataConOrigArgTys con - , isUnliftedType arg_ty + , isLiftedType_maybe arg_ty /= Just True , not (ok_ty arg_ty) ] cls_key = classKey cls @@ -756,7 +758,7 @@ cond_args cls _ _ rep_tc | cls_key == eqClassKey = check_in arg_ty ordOpTbl | cls_key == ordClassKey = check_in arg_ty ordOpTbl | cls_key == showClassKey = check_in arg_ty boxConTbl - | cls_key == liftClassKey = check_in arg_ty litConTbl + | cls_key == liftClassKey = True -- Lift is levity-polymorphic | otherwise = False -- Read, Ix etc check_in :: Type -> [(Type,a)] -> Bool diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 4d813b0086..adaea90767 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -639,7 +639,8 @@ tcExpr (HsStatic fvs expr) res_ty ; emitStaticConstraints lie -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName + [p_ty] ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM ; return $ mkHsWrapCo co $ HsApp noExt @@ -1040,7 +1041,7 @@ tcArithSeq witness seq@(From expr) res_ty = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName elt_ty + enumFromName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from wit' (From expr') } @@ -1049,7 +1050,7 @@ tcArithSeq witness seq@(FromThen expr1 expr2) res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName elt_ty + enumFromThenName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_then wit' (FromThen expr1' expr2') } @@ -1058,7 +1059,7 @@ tcArithSeq witness seq@(FromTo expr1 expr2) res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName elt_ty + enumFromToName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq enum_from_to wit' (FromTo expr1' expr2') } @@ -1068,7 +1069,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName elt_ty + enumFromThenToName [elt_ty] ; return $ mkHsWrap wrap $ ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } @@ -2041,7 +2042,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var)) setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE newMethodFromName (OccurrenceOf id_name) - THNames.liftName id_ty + THNames.liftName + [getRuntimeRep id_ty, id_ty] -- Update the pending splices ; ps <- readMutVar ps_var diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index bb4b643e86..b02494b634 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -54,8 +54,6 @@ import FamInst import FamInstEnv import PrelNames import THNames -import Module ( moduleName, moduleNameString - , moduleUnitId, unitIdString ) import MkId ( coerceId ) import PrimOp import SrcLoc @@ -1559,68 +1557,36 @@ Example: ==> instance (Lift a) => Lift (Foo a) where - lift (Foo a) - = appE - (conE - (mkNameG_d "package-name" "ModuleName" "Foo")) - (lift a) - lift (u :^: v) - = infixApp - (lift u) - (conE - (mkNameG_d "package-name" "ModuleName" ":^:")) - (lift v) - -Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what -'Foo would be when using the -XTemplateHaskell extension. To make sure that --XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke -makeG_d. + lift (Foo a) = [| Foo a |] + lift ((:^:) u v) = [| (:^:) u v |] + + liftTyped (Foo a) = [|| Foo a ||] + liftTyped ((:^:) u v) = [|| (:^:) u v ||] -} + gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff) -gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag) +gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag) where - lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) - (map pats_etc data_cons) + lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_exp) data_cons) + liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr) + (map (pats_etc mk_texp) data_cons) + + mk_exp = ExpBr NoExt + mk_texp = TExpBr NoExt data_cons = tyConDataCons tycon - pats_etc data_con + pats_etc mk_bracket data_con = ([con_pat], lift_Expr) where con_pat = nlConVarPat data_con_RDR as_needed data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con as_needed = take con_arity as_RDRs - lifted_as = zipWithEqual "mk_lift_app" mk_lift_app - tys_needed as_needed - tycon_name = tyConName tycon - is_infix = dataConIsInfix data_con - tys_needed = dataConOrigArgTys data_con - - mk_lift_app ty a - | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR) - (nlHsVar a) - | otherwise = nlHsApp (nlHsVar litE_RDR) - (primLitOp (mkBoxExp (nlHsVar a))) - where (primLitOp, mkBoxExp) = primLitOps "Lift" ty - - pkg_name = unitIdString . moduleUnitId - . nameModule $ tycon_name - mod_name = moduleNameString . moduleName . nameModule $ tycon_name - con_name = occNameString . nameOccName . dataConName $ data_con - - conE_Expr = nlHsApp (nlHsVar conE_RDR) - (nlHsApps mkNameG_dRDR - (map (nlHsLit . mkHsString) - [pkg_name, mod_name, con_name])) - - lift_Expr - | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2] - | otherwise = foldl' mk_appE_app conE_Expr lifted_as - (a1:a2:_) = lifted_as - -mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -mk_appE_app a b = nlHsApps appE_RDR [a, b] + lift_Expr = noLoc (HsBracket NoExt (mk_bracket br_body)) + br_body = nlHsApps (Exact (dataConName data_con)) + (map nlHsVar as_needed) {- ************************************************************************ @@ -2134,17 +2100,6 @@ primOrdOps :: String -- The class involved -- See Note [Deriving and unboxed types] in TcDerivInfer primOrdOps str ty = assoc_ty_id str ordOpTbl ty -primLitOps :: String -- The class involved - -> Type -- The type - -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value - , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value - ) -primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v) - where - boxed v - | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v - | otherwise = assoc_ty_id str boxConTbl ty v - ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl = [(charPrimTy , (ltChar_RDR , leChar_RDR diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index c495a72d49..845e2029ed 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -177,13 +177,14 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $ tcInferRhoNC expr -- NC for no context; tcBracket does that + ; let rep = getRuntimeRep expr_ty ; meta_ty <- tcTExpTy expr_ty ; ps' <- readMutVar ps_ref ; texpco <- tcLookupId unsafeTExpCoerceName ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr") rn_expr - (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty]) + (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty]) (noLoc (HsTcBracketOut noExt brack ps')))) meta_ty res_ty } tcTypedBracket _ other_brack _ @@ -230,7 +231,8 @@ tcTExpTy exp_ty = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty) ; q <- tcLookupTyCon qTyConName ; texp <- tcLookupTyCon tExpTyConName - ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) } + ; let rep = getRuntimeRep exp_ty + ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) } where err_msg ty = vcat [ text "Illegal polytype:" <+> ppr ty @@ -469,12 +471,13 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name -- A splice inside brackets tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty = do { res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty ; meta_exp_ty <- tcTExpTy res_ty ; expr' <- setStage pop_stage $ setConstraintVar lie_var $ tcMonoExpr expr (mkCheckExpType meta_exp_ty) ; untypeq <- tcLookupId unTypeQName - ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr' + ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr' ; ps <- readMutVar ps_var ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) |