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   pga_loopl,
  32   pga_loopr,
  33   pga_kappa
  34 ) where
  35 import Control.Category ( (>>>) )
  36 import qualified Control.Category
  37 import GHC.HetMet.GArrow
  38
  39 -------------------------------------------------------------------------
  40 -- Used internally by the compiler, subject to change without notice!!
  41
  42 newtype PGArrow g x y = PGArrowD { unG :: GArrowSTKCL g => g x y }
  43
  44 pga_id        :: forall g x. PGArrow g x x
  45 pga_id        =  PGArrowD { unG = Control.Category.id }
  46 pga_comp      :: forall g x y z. PGArrow g x y -> PGArrow g y z -> PGArrow g x z
  47 pga_comp f g  =  PGArrowD { unG = unG f >>> unG g }
  48 pga_first     :: forall g x y z . PGArrow g x y -> PGArrow g (GArrowTensor g x z) (GArrowTensor g y z)
  49 pga_first f   =  PGArrowD { unG = ga_first $ unG f }
  50 pga_second    :: forall g x y z . PGArrow g x y -> PGArrow g (GArrowTensor g z x) (GArrowTensor g z y)
  51 pga_second f  =  PGArrowD { unG = ga_second $ unG f }
  52 pga_cancell   :: forall g x . PGArrow g (GArrowTensor g (GArrowUnit g) x)         x
  53 pga_cancell   =  PGArrowD { unG = ga_cancell }
  54 pga_cancelr   :: forall g x . PGArrow g    (GArrowTensor g x (GArrowUnit g))      x
  55 pga_cancelr   =  PGArrowD { unG = ga_cancelr }
  56 pga_uncancell :: forall g x . PGArrow g     x      (GArrowTensor g (GArrowUnit g) x)
  57 pga_uncancell =  PGArrowD { unG = ga_uncancell }
  58 pga_uncancelr :: forall g x . PGArrow g     x         (GArrowTensor g x (GArrowUnit g))
  59 pga_uncancelr =  PGArrowD { unG = ga_uncancelr }
  60 pga_assoc     :: forall g x y z . PGArrow g (GArrowTensor g (GArrowTensor g x y) z) (GArrowTensor g x (GArrowTensor g y z))
  61 pga_assoc     =  PGArrowD { unG = ga_assoc }
  62 pga_unassoc   :: forall g x y z . PGArrow g (GArrowTensor g x (GArrowTensor g y z)) (GArrowTensor g (GArrowTensor g x y) z)
  63 pga_unassoc   =  PGArrowD { unG = ga_unassoc }
  64 pga_copy      :: forall g x . PGArrow g x (GArrowTensor g x x)
  65 pga_copy      =  PGArrowD { unG = ga_copy }
  66 pga_drop      :: forall g x . PGArrow g x (GArrowUnit g)
  67 pga_drop      =  PGArrowD { unG = ga_drop }
  68 pga_swap      :: forall g x y . PGArrow g (GArrowTensor g x y) (GArrowTensor g y x)
  69 pga_swap      =  PGArrowD { unG = ga_swap }
  70 pga_applyl    :: forall g x y . PGArrow g (GArrowTensor g x (GArrowExponent g x y)   ) y
  71 pga_applyl    =  error "not implemented"
  72 pga_applyr    :: forall g x y . PGArrow g (GArrowTensor g (GArrowExponent g x y) x) y
  73 pga_applyr    =  error "not implemented"
  74 pga_curryl    :: forall g x y z . PGArrow g (GArrowTensor g x y) z  ->  PGArrow g x (GArrowExponent g y z)
  75 pga_curryl    =  error "not implemented"
  76 pga_curryr    :: forall g x y z . PGArrow g (GArrowTensor g x y) z  ->  PGArrow g y (GArrowExponent g x z)
  77 pga_curryr    =  error "not implemented"
  78 pga_kappa     :: forall g x y . (g (GArrowUnit g) x -> g (GArrowUnit g) y) -> g x y
  79 pga_kappa     =  error "not implemented"
  80 pga_loopr     :: forall g x y z . PGArrow g (GArrowTensor g x z) (GArrowTensor g y z) -> PGArrow g x y
  81 pga_loopr f   =  PGArrowD { unG = ga_loopr $ unG f }
  82 pga_loopl     :: forall g x y z . PGArrow g (GArrowTensor g z x) (GArrowTensor g z y) -> PGArrow g x y
  83 pga_loopl f   =  PGArrowD { unG = ga_loopl $ unG f }