1 {-# LANGUAGE RankNTypes, ScopedTypeVariables, NoMonomorphismRestriction, TypeOperators, FunctionalDependencies, FlexibleContexts #-}
2 -----------------------------------------------------------------------------
4 -- Module : GHC.HetMet.GArrow
6 -- License : public domain
8 -- Maintainer : Adam Megacz <megacz@acm.org>
9 -- Stability : experimental
10 -- Portability : portable
12 module GHC.HetMet.Private (
35 import Control.Category ( (>>>) )
36 import qualified Control.Category
37 import GHC.HetMet.GArrow
39 -------------------------------------------------------------------------
40 -- Used internally by the compiler, subject to change without notice!!
42 newtype PGArrow g x y = PGArrowD { unG :: GArrowSTKCL g => g x y }
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 }