- -- Non-empty list in all of these, so that the identity coercion
- -- is always exactly CoHole, not, say, (CoTyLams [])
- | CoApps [Var] -- [] x1 .. xn; the xi are dicts or coercions
- | CoTyApps [Type] -- [] t1 .. tn
- | CoLams [Id] -- \x1..xn. []; the xi are dicts or coercions
- | CoTyLams [TyVar] -- \a1..an. []
- | CoLet (LHsBinds Id) -- Would be nicer to be core bindings
-
-instance Outputable ExprCoFn where
- ppr CoHole = ptext SLIT("<>")
- ppr (ExprCoFn co) = ppr co
- ppr (CoApps ids) = ppr CoHole <+> interppSP ids
- ppr (CoTyApps tys) = ppr CoHole <+> hsep (map pprParendType tys)
- ppr (CoTyLams tvs) = sep [ptext SLIT("/\\") <> hsep (map (pprBndr LambdaBind) tvs),
- ptext SLIT("->") <+> ppr CoHole]
- ppr (CoLams ids) = sep [ptext SLIT("\\") <> hsep (map (pprBndr LambdaBind) ids),
- ptext SLIT("->") <+> ppr CoHole]
- ppr (CoLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds),
- ppr CoHole]
- ppr (CoCompose co1 co2) = sep [ppr co1, ptext SLIT("<.>"), ppr co2]
-
-(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-CoHole <.> c = c
-c <.> CoHole = c
-c1 <.> c2 = c1 `CoCompose` c2
-
-idCoercion :: ExprCoFn
-idCoercion = CoHole
-
-isIdCoercion :: ExprCoFn -> Bool
-isIdCoercion CoHole = True
-isIdCoercion other = False
+ | WpApp Var -- [] x; the xi are dicts or coercions
+ | WpTyApp Type -- [] t
+ | WpLam Id -- \x. []; the xi are dicts or coercions
+ | WpTyLam TyVar -- \a. []
+
+ -- Non-empty bindings, so that the identity coercion
+ -- is always exactly WpHole
+ | WpLet (LHsBinds Id) -- let binds in []
+ -- (would be nicer to be core bindings)
+
+instance Outputable HsWrapper where
+ ppr co_fn = pprHsWrapper (ptext SLIT("<>")) co_fn
+
+pprHsWrapper :: SDoc -> HsWrapper -> SDoc
+pprHsWrapper it WpHole = it
+pprHsWrapper it (WpCompose f1 f2) = pprHsWrapper (pprHsWrapper it f2) f1
+pprHsWrapper it (WpCo co) = it <+> ptext SLIT("`cast`") <+> pprParendType co
+pprHsWrapper it (WpApp id) = it <+> ppr id
+pprHsWrapper it (WpTyApp ty) = it <+> ptext SLIT("@") <+> pprParendType ty
+pprHsWrapper it (WpLam id) = ptext SLIT("\\") <> pprBndr LambdaBind id <> dot <+> it
+pprHsWrapper it (WpTyLam tv) = ptext SLIT("/\\") <> pprBndr LambdaBind tv <> dot <+> it
+pprHsWrapper it (WpLet binds) = sep [ptext SLIT("let") <+> braces (ppr binds), it]
+
+(<.>) :: HsWrapper -> HsWrapper -> HsWrapper
+WpHole <.> c = c
+c <.> WpHole = c
+c1 <.> c2 = c1 `WpCompose` c2
+
+mkWpTyApps :: [Type] -> HsWrapper
+mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
+
+mkWpApps :: [Id] -> HsWrapper
+mkWpApps ids = mk_co_fn WpApp (reverse ids)
+
+mkWpTyLams :: [TyVar] -> HsWrapper
+mkWpTyLams ids = mk_co_fn WpTyLam ids
+
+mkWpLams :: [Id] -> HsWrapper
+mkWpLams ids = mk_co_fn WpLam ids
+
+mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+mk_co_fn f as = foldr (WpCompose . f) WpHole as
+
+idHsWrapper :: HsWrapper
+idHsWrapper = WpHole
+
+isIdHsWrapper :: HsWrapper -> Bool
+isIdHsWrapper WpHole = True
+isIdHsWrapper other = False