-data ExprCoFn
- = CoHole -- The identity coercion
- | CoCompose ExprCoFn ExprCoFn
- | CoApps ExprCoFn [Id] -- Non-empty list
- | CoTyApps ExprCoFn [Type] -- in all of these
- | CoLams [Id] ExprCoFn -- so that the identity coercion
- | CoTyLams [TyVar] ExprCoFn -- is just Hole
- | CoLet (LHsBinds Id) ExprCoFn -- Would be nicer to be core bindings
-
-(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
-(<.>) = CoCompose
-
-idCoercion :: ExprCoFn
-idCoercion = CoHole
-
-isIdCoercion :: ExprCoFn -> Bool
-isIdCoercion CoHole = True
-isIdCoercion other = False
+data HsWrapper
+ = WpHole -- The identity coercion
+
+ | WpCompose HsWrapper HsWrapper -- (\a1..an. []) `WpCompose` (\x1..xn. [])
+ -- = (\a1..an \x1..xn. [])
+
+ | WpCast Coercion -- A cast: [] `cast` co
+ -- Guaranteedn not the identity coercion
+
+ | WpApp Var -- [] d the 'd' is a type-class dictionary
+ | WpTyApp Type -- [] t the 't' is a type or corecion
+ | WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable
+ | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
+ | WpInline -- inline_me [] Wrap inline around the thing
+
+ -- 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 wrap =
+ let
+ help it WpHole = it
+ help it (WpCompose f1 f2) = help (help it f2) f1
+ help it (WpCast co) = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
+ help it (WpApp id) = sep [it, nest 2 (ppr id)]
+ help it (WpTyApp ty) = sep [it, ptext (sLit "@") <+> pprParendType ty]
+ help it (WpLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
+ help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
+ help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
+ help it WpInline = sep [ptext (sLit "_inline_me_"), it]
+ in
+ -- in debug mode, print the wrapper
+ -- otherwise just print what's inside
+ getPprStyle (\ s -> if debugStyle s then (help it wrap) else 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 _ = False