diff options
Diffstat (limited to 'compiler/hsSyn')
| -rw-r--r-- | compiler/hsSyn/Convert.lhs | 48 | ||||
| -rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 30 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 2 | ||||
| -rw-r--r-- | compiler/hsSyn/HsPat.lhs | 2 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 126 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 8 |
6 files changed, 112 insertions, 104 deletions
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f84776546a..afb6933e30 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -7,7 +7,7 @@ This module converts Template Haskell syntax into HsSyn \begin{code} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, - convertToHsType, convertToHsPred, + convertToHsType, thRdrNameGuesses ) where import HsSyn as Hs @@ -59,10 +59,6 @@ convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t -convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName) -convertToHsPred loc t - = initCvt loc $ wrapMsg "type" t $ cvtPred t - ------------------------------------------------------------------- newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } -- Push down the source location; @@ -190,8 +186,8 @@ cvtDec (ClassD ctxt cl tvs fds decs) cvtDec (InstanceD ctxt ty decs) = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs ; ctxt' <- cvtContext ctxt - ; L loc pred' <- cvtPredTy ty - ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred' + ; L loc ty' <- cvtType ty + ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') } cvtDec (ForeignD ford) @@ -356,7 +352,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just cs') } where cvt_one c = do { c' <- tconName c - ; returnL $ HsPredTy $ HsClassP c' [] } + ; returnL $ HsTyVar c' } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName)) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') } @@ -783,27 +779,18 @@ cvt_tv (TH.KindedTV nm ki) cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } -cvtPred :: TH.Pred -> CvtM (LHsPred RdrName) +cvtPred :: TH.Pred -> CvtM (LHsType RdrName) cvtPred (TH.ClassP cla tys) = do { cla' <- if isVarName cla then tName cla else tconName cla ; tys' <- mapM cvtType tys - ; returnL $ HsClassP cla' tys' + ; mk_apps (HsTyVar cla') tys' } cvtPred (TH.EqualP ty1 ty2) = do { ty1' <- cvtType ty1 ; ty2' <- cvtType ty2 - ; returnL $ HsEqualP ty1' ty2' + ; returnL $ HsEqTy ty1' ty2' } -cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName) -cvtPredTy ty - = do { (head, tys') <- split_ty_app ty - ; case head of - ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' } - VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' } - _ -> failWith (ptext (sLit "Malformed predicate") <+> - text (TH.pprint ty)) } - cvtType :: TH.Type -> CvtM (LHsType RdrName) cvtType ty = do { (head_ty, tys') <- split_ty_app ty @@ -812,18 +799,18 @@ cvtType ty | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy Boxed tys') + else returnL (HsTupleTy (HsBoxyTuple liftedTypeKind) tys') | n == 1 -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon BoxedTuple n))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) - else returnL (HsTupleTy Unboxed tys') + else returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' + -> mk_apps (HsTyVar (getRdrName (tupleTyCon UnboxedTuple n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' @@ -848,10 +835,11 @@ cvtType ty _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty)) } - where - mk_apps head_ty [] = returnL head_ty - mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty - ; mk_apps (HsAppTy head_ty' ty) tys } + +mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName) +mk_apps head_ty [] = returnL head_ty +mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty + ; mk_apps (HsAppTy head_ty' ty) tys } split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName]) split_ty_app ty = go ty [] @@ -992,8 +980,8 @@ isBuiltInOcc ctxt_ns occ go_tuple _ _ = Nothing tup_name n - | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n) - | otherwise = Name.getName (tupleCon Boxed n) + | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon BoxedTuple n) + | otherwise = Name.getName (tupleCon BoxedTuple n) -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 4a57727785..7bc74e295b 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -432,9 +432,6 @@ instance (OutputableBndr id) => Outputable (IPBind id) where %************************************************************************ \begin{code} --- A HsWrapper is an expression with a hole in it --- We need coercions to have concrete form so that we can zonk them - data HsWrapper = WpHole -- The identity coercion @@ -444,8 +441,8 @@ data HsWrapper -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) - | WpCast Coercion -- A cast: [] `cast` co - -- Guaranteed not the identity coercion + | WpCast LCoercion -- A cast: [] `cast` co + -- Guaranteed not the identity coercion -- Evidence abstraction and application -- (both dictionaries and coercions) @@ -502,24 +499,24 @@ data EvBind = EvBind EvVar EvTerm data EvTerm = EvId EvId -- Term-level variable-to-variable bindings - -- (no coercion variables! they come via EvCoercion) + -- (no coercion variables! they come via EvCoercionBox) - | EvCoercion Coercion -- Coercion bindings + | EvCoercionBox LCoercion -- (Boxed) coercion bindings - | EvCast EvVar Coercion -- d |> co + | EvCast EvVar LCoercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] + + | EvTupleSel EvId Int -- n'th component of the tuple + + | EvTupleMk [EvId] -- tuple built from this stuff | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no -- selector Id. We count up from _0_ deriving( Data, Typeable) - -evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) - | otherwise = EvId v \end{code} Note [EvBinds/EvTerm] @@ -560,7 +557,7 @@ mkWpEvApps :: [EvTerm] -> HsWrapper mkWpEvApps args = mk_co_app_fn WpEvApp args mkWpEvVarApps :: [EvVar] -> HsWrapper -mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs) +mkWpEvVarApps vs = mkWpEvApps (map EvId vs) mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids @@ -630,11 +627,14 @@ instance Outputable EvBindsVar where instance Outputable EvBind where ppr (EvBind v e) = ppr v <+> equals <+> ppr e + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where ppr (EvId v) = ppr v ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvCoercionBox co) = ptext (sLit "CO") <+> ppr co + ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n)) + ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 9d441b707d..995c66068c 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -425,7 +425,7 @@ ppr_expr (SectionR op expr) pp_infixly v = sep [pprHsInfix v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) - = tupleParens boxity (fcat (ppr_tup_args exprs)) + = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs)) where ppr_tup_args [] = [] ppr_tup_args (Present e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 71dfe1d969..5c404a6ae8 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -252,7 +252,7 @@ pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) -pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats) +pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) pprPat (ConPatIn con details) = pprUserCon con details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index f8b7be47af..89a002b63c 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -11,9 +11,8 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - HsExplicitFlag(..), + HsTupleSort(..), HsExplicitFlag(..), HsContext, LHsContext, - HsPred(..), LHsPred, HsQuasiQuote(..), LBangType, BangType, HsBang(..), @@ -25,7 +24,10 @@ module HsTypes ( hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName, hsTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, - splitHsInstDeclTy, splitHsFunType, + splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, + splitHsForAllTy, splitLHsForAllTy, + splitHsClassTy_maybe, splitLHsClassTy_maybe, + splitHsFunType, splitHsAppTys, mkHsAppTys, -- Type place holder @@ -37,7 +39,7 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) -import NameSet( FreeVars ) +import NameSet ( FreeVars ) import Type import HsDoc import BasicTypes @@ -124,14 +126,7 @@ This is the syntax for types as seen in type signatures. \begin{code} type LHsContext name = Located (HsContext name) -type HsContext name = [LHsPred name] - -type LHsPred name = Located (HsPred name) - -data HsPred name = HsClassP name [LHsType name] -- class constraint - | HsEqualP (LHsType name) (LHsType name)-- equality constraint - | HsIParam (IPName name) (LHsType name) - deriving (Data, Typeable) +type HsContext name = [LHsType name] type LHsType name = Located (HsType name) @@ -156,7 +151,7 @@ data HsType name | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy Boxity + | HsTupleTy HsTupleSort [LHsType name] -- Element types (length gives arity) | HsOpTy (LHsType name) (Located name) (LHsType name) @@ -165,12 +160,11 @@ data HsType name -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - | HsPredTy (HsPred name) -- Only used in the type of an instance - -- declaration, eg. Eq [a] -> Eq a - -- ^^^^ - -- HsPredTy - -- Note no need for location info on the - -- Enclosed HsPred; the one on the type will do + | HsIParamTy (IPName name) -- (?x :: ty) + (LHsType name) -- Implicit parameters as they occur in contexts + + | HsEqTy (LHsType name) -- ty1 ~ ty2 + (LHsType name) -- Always allowed even without TypeOperators, and has special kinding rule | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature @@ -191,6 +185,10 @@ data HsType name deriving (Data, Typeable) +data HsTupleSort = HsUnboxedTuple + | HsBoxyTuple Kind -- Either a Constraint or normal tuple: resolved during type checking + deriving (Data, Typeable) + data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) data ConDeclField name -- Record fields have Haddoc docs on them @@ -223,7 +221,7 @@ mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (noLoc []) ty -- Even if tvs is empty, we still make a HsForAll! -- In the Implicit case, this signals the place to do implicit quantification -- In the Explicit case, it prevents implicit quantification @@ -305,22 +303,53 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) -- Add noLocs for inner nodes of the application; -- they are never used -splitHsInstDeclTy - :: OutputableBndr name - => LHsType name - -> ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) - -- Split up an instance decl type, returning the pieces +splitHsInstDeclTy_maybe :: HsType name + -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) +splitHsInstDeclTy_maybe ty + = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty) -splitHsInstDeclTy linst_ty@(L _ inst_ty) - = case inst_ty of - HsParTy ty -> splitHsInstDeclTy ty - HsForAllTy _ tvs cxt ty -> split_tau tvs (unLoc cxt) ty - _ -> split_tau [] [] linst_ty - -- The type vars should have been computed by now, even if they were implicit +splitLHsInstDeclTy_maybe + :: LHsType name + -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name]) + -- Split up an instance decl type, returning the pieces +splitLHsInstDeclTy_maybe inst_ty = do + let (tvs, cxt, ty) = splitLHsForAllTy inst_ty + (cls, tys) <- splitLHsClassTy_maybe ty + return (tvs, cxt, cls, tys) + +splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name) +splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty) + +splitLHsForAllTy + :: LHsType name + -> ([LHsTyVarBndr 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) + _ -> ([], [], poly_ty) + -- The type vars should have been computed by now, even if they were implicit + +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]) +--- Watch out.. in ...deriving( Show )... we use this on +--- the list of partially applied predicates in the deriving, +--- so there can be zero args. + +-- In TcDeriv we also use this to figure out what data type is being +-- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). +splitLHsClassTy_maybe ty + = checkl ty [] where - split_tau tvs cxt (L loc (HsPredTy (HsClassP cls tys))) = (tvs, cxt, L loc cls, tys) - split_tau tvs cxt (L _ (HsParTy ty)) = split_tau tvs cxt ty - split_tau _ _ _ = pprPanic "splitHsInstDeclTy" (ppr inst_ty) + 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 -- Splits HsType into the (init, last) parts -- Breaks up any parens in the result type: @@ -348,15 +377,6 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name _) = ppr name ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind] -instance OutputableBndr name => Outputable (HsPred name) where - ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys) - ppr (HsEqualP t1 t2) = hsep [pprLHsType t1, ptext (sLit "~"), - pprLHsType t2] - ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] - -pprLHsType :: OutputableBndr name => LHsType name -> SDoc -pprLHsType = pprParendHsType . unLoc - pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) @@ -369,16 +389,9 @@ pprHsForAll exp tvs cxt pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext [] = empty -pprHsContext [L _ pred] - | noParenHsPred pred = ppr pred <+> darrow +pprHsContext [L _ pred] = ppr pred <+> darrow pprHsContext cxt = ppr_hs_context cxt <+> darrow -noParenHsPred :: HsPred name -> Bool --- c.f. TypeRep.noParenPred -noParenHsPred (HsClassP {}) = True -noParenHsPred (HsEqualP {}) = True -noParenHsPred (HsIParam {}) = False - ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc ppr_hs_context [] = empty ppr_hs_context cxt = parens (interpp'SP cxt) @@ -446,14 +459,21 @@ ppr_mono_ty _ (HsQuasiQuoteTy qq) = ppr qq ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds ppr_mono_ty _ (HsTyVar name) = ppr name ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 -ppr_mono_ty _ (HsTupleTy con tys) = tupleParens con (interpp'SP tys) +ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + HsBoxyTuple _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) -ppr_mono_ty _ (HsPredTy pred) = ppr pred +ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 <+> char '~' <+> ppr_mono_lty pREC_OP ty2 + ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cd95571964..3451e4ce6c 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -173,15 +173,15 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e -mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id +mkHsWrapCo :: LCoercion -> HsExpr id -> HsExpr id mkHsWrapCo (Refl _) e = e mkHsWrapCo co e = mkHsWrap (WpCast co) e -mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: LCoercion -> LHsExpr id -> LHsExpr id mkLHsWrapCo (Refl _) e = e mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e) -coToHsWrapper :: Coercion -> HsWrapper +coToHsWrapper :: LCoercion -> HsWrapper coToHsWrapper (Refl _) = idHsWrapper coToHsWrapper co = WpCast co @@ -189,7 +189,7 @@ mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty -mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo :: LCoercion -> Pat id -> Type -> Pat id mkHsWrapPatCo (Refl _) pat _ = pat mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty |