move Arrange into NaturalDeductionContext
[coq-hetmet.git] / examples / Unflattening.hs
1 {-# OPTIONS_GHC -XModalTypes -ddump-types -XNoMonoPatBinds -XMultiParamTypeClasses #-}
2 module Unflattening
3 where
4 import GHC.HetMet.CodeTypes hiding ((-))
5 import GHC.HetMet.GArrow
6 import Control.Category
7 import Control.Arrow
8 import Prelude hiding ( id, (.) )
9
10 --------------------------------------------------------------------------------
11 -- Unflattening
12
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 <[ () ]>
16
17 <[ u ]> = Prelude.error "FIXME"
18
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:
22
23 newtype Code x y = Code { unCode :: forall a. <[ x -> y ]>@a }
24
25 instance Category Code where
26   id             = Code <[ \x -> x ]>
27   f . g          = Code <[ \x -> ~~(unCode f) (~~(unCode g) x) ]>
28
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 ]>
33
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) ]>
39
40 instance GArrowDrop Code (,) () where
41   ga_drop        = Code <[ \_ -> u ]>
42
43 instance GArrowCopy Code (,) () where
44   ga_copy        = Code <[ \x -> (x,x) ]>
45
46 instance GArrowSwap Code (,) () where
47   ga_swap        = Code <[ \(x,y) -> (y,x) ]>