1 {-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses #-}
4 import GHC.HetMet.CodeTypes hiding ((-))
5 import GHC.HetMet.GArrow
6 import Control.Category
8 import Prelude hiding ( id, (.) )
10 --------------------------------------------------------------------------------
13 -- The current implementation has problems with literals at level>0;
14 -- there are special-purpose hacks for Int and Char, but none for
15 -- unit. So I use this instead as a placeholder for <[ () ]>
17 <[ u ]> = Prelude.error "FIXME"
19 -- This more or less "undoes" the flatten function. People often ask
20 -- me how you "translate generalized arrows back into multi-level
21 -- terms".. I'm not sure why you'd want to do that, but this is how:
23 newtype Code x y = Code { unCode :: forall a. <[ x -> y ]>@a }
25 instance Category Code where
26 id = Code <[ \x -> x ]>
27 f . g = Code <[ \x -> ~~(unCode f) (~~(unCode g) x) ]>
29 instance GArrow Code (,) () where
30 ga_first f = Code <[ \(x,y) -> ((~~(unCode f) x),y) ]>
31 ga_second f = Code <[ \(x,y) -> (x ,(~~(unCode f) y)) ]>
32 ga_cancell = Code <[ \(_,x) -> x ]>
34 ga_cancelr = Code <[ \(x,_) -> x ]>
35 ga_uncancell = Code <[ \x -> (u,x) ]>
36 ga_uncancelr = Code <[ \x -> (x,u) ]>
37 ga_assoc = Code <[ \((x,y),z) -> (x,(y,z)) ]>
38 ga_unassoc = Code <[ \(x,(y,z)) -> ((x,y),z) ]>
40 instance GArrowDrop Code (,) () where
41 ga_drop = Code <[ \_ -> u ]>
43 instance GArrowCopy Code (,) () where
44 ga_copy = Code <[ \x -> (x,x) ]>
46 instance GArrowSwap Code (,) () where
47 ga_swap = Code <[ \(x,y) -> (y,x) ]>