-split :: Int -> TcId -> TcId -> Inst
- -> TcM (TcDictBinds, [LHsExpr TcId])
--- (split n split_id root_id wanted) returns
--- * a list of 'n' expressions, all of which witness 'avail'
--- * a bunch of auxiliary bindings to support these expressions
--- * one or zero insts needed to witness the whole lot
--- (maybe be zero if the initial Inst is a Given)
---
--- NB: 'wanted' is just a template
-
-split n split_id root_id wanted
- = go n
- where
- ty = linearInstType wanted
- pair_ty = mkTyConApp pairTyCon [ty,ty]
- id = instToId wanted
- occ = getOccName id
- loc = getSrcLoc id
- span = instSpan wanted
-
- go 1 = returnM (emptyBag, [L span $ HsVar root_id])
-
- go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
- expand n rhss `thenM` \ (binds2, rhss') ->
- returnM (binds1 `unionBags` binds2, rhss')
-
- -- (expand n rhss)
- -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
- -- e.g. expand 3 [rhs1, rhs2]
- -- = ( { x = split rhs1 },
- -- [fst x, snd x, rhs2] )
- expand n rhss
- | n `rem` 2 == 0 = go rhss -- n is even
- | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
- returnM (binds', head rhss : rhss')
- where
- go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
- returnM (listToBag binds', concat rhss')
-
- do_one rhs = newUnique `thenM` \ uniq ->
- tcLookupId fstName `thenM` \ fst_id ->
- tcLookupId sndName `thenM` \ snd_id ->
- let
- x = mkUserLocal occ uniq pair_ty loc
- in
- returnM (L span (VarBind x (mk_app span split_id rhs)),
- [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
-
-mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var))
-
-mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
-