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) ]>