GHC/HetMet/Private.hs

   1 {-# LANGUAGE RankNTypes, ScopedTypeVariables, NoMonomorphismRestriction, TypeOperators, FunctionalDependencies, FlexibleContexts #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  GHC.HetMet.GArrow
   5 -- Copyright   :  none
   6 -- License     :  public domain
   7 --
   8 -- Maintainer  :  Adam Megacz <megacz@acm.org>
   9 -- Stability   :  experimental
  10 -- Portability :  portable
  11
  12 module GHC.HetMet.Private (
  13   PGArrow,
  14   pga_id,
  15   pga_comp,
  16   pga_first,
  17   pga_second,
  18   pga_cancell,
  19   pga_cancelr,
  20   pga_uncancell,
  21   pga_uncancelr,
  22   pga_assoc,
  23   pga_unassoc,
  24   pga_copy,
  25   pga_drop,
  26   pga_swap,
  27   pga_applyl,
  28   pga_applyr,
  29   pga_curryl,
  30   pga_curryr
  31 ) where
  32 import Control.Category ( (>>>) )
  33 import qualified Control.Category
  34 import GHC.HetMet.GArrow
  35
  36 -------------------------------------------------------------------------
  37 -- Used internally by the compiler, subject to change without notice!!
  38
  39 newtype PGArrow g x y = PGArrowD { unG :: GArrowSTKC g (,) () => g x y }
  40
  41 pga_id        :: forall g x. PGArrow g x x
  42 pga_id        =  PGArrowD { unG = Control.Category.id }
  43 pga_comp      :: forall g x y z. PGArrow g x y -> PGArrow g y z -> PGArrow g x z
  44 pga_comp f g  =  PGArrowD { unG = unG f >>> unG g }
  45 pga_first     :: forall g x y z . PGArrow g x y -> PGArrow g (x , z) (y , z)
  46 pga_first f   =  PGArrowD { unG = ga_first $ unG f }
  47 pga_second    :: forall g x y z . PGArrow g x y -> PGArrow g (z , x) (z , y)
  48 pga_second f  =  PGArrowD { unG = ga_second $ unG f }
  49 pga_cancell   :: forall g x . PGArrow g ((),x)         x
  50 pga_cancell   =  PGArrowD { unG = ga_cancell }
  51 pga_cancelr   :: forall g x . PGArrow g    (x,())      x
  52 pga_cancelr   =  PGArrowD { unG = ga_cancelr }
  53 pga_uncancell :: forall g x . PGArrow g     x      ((),x)
  54 pga_uncancell =  PGArrowD { unG = ga_uncancell }
  55 pga_uncancelr :: forall g x . PGArrow g     x         (x,())
  56 pga_uncancelr =  PGArrowD { unG = ga_uncancelr }
  57 pga_assoc     :: forall g x y z . PGArrow g ((x, y),z ) ( x,(y ,z))
  58 pga_assoc     =  PGArrowD { unG = ga_assoc }
  59 pga_unassoc   :: forall g x y z . PGArrow g ( x,(y ,z)) ((x, y),z )
  60 pga_unassoc   =  PGArrowD { unG = ga_unassoc }
  61 pga_copy      :: forall g x . PGArrow g x (x,x)
  62 pga_copy      =  PGArrowD { unG = ga_copy }
  63 pga_drop      :: forall g x . PGArrow g x ()
  64 pga_drop      =  PGArrowD { unG = ga_drop }
  65 pga_swap      :: forall g x y . PGArrow g (x,y) (y,x)
  66 pga_swap      =  PGArrowD { unG = ga_swap }
  67 pga_applyl    :: forall g x y . PGArrow g (x,(x->y)   ) y
  68 pga_applyl    =  error "not implemented"
  69 pga_applyr    :: forall g x y . PGArrow g (   (x->y),x) y
  70 pga_applyr    =  error "not implemented"
  71 pga_curryl    :: forall g x y z . PGArrow g (x,y) z  ->  PGArrow g x (y->z)
  72 pga_curryl    =  error "not implemented"
  73 pga_curryr    :: forall g x y z . PGArrow g (x,y) z  ->  PGArrow g y (x->z)
  74 pga_curryr    =  error "not implemented"
  75 --pga_kappa     :: forall g x y . (g u x -> g u y) -> g x y
  76 --pga_kappa     =  error "not implemented"