add GArrowSTKCL for flattening of fixpoints

diff --git a/GHC/HetMet/CodeTypes.hs b/GHC/HetMet/CodeTypes.hs
index d629119..8269686 100644 (file)
--- a/GHC/HetMet/CodeTypes.hs
+++ b/GHC/HetMet/CodeTypes.hs
@@ -31,7 +31,7 @@ hetmet_csp = Prelude.error "hetmet_csp should never be evaluated; did you forget
 
 hetmet_flatten ::
    forall g .
-    GArrowSTKC g =>
+    GArrowSTKCL g =>
       forall x y.
          <[ x -> y ]>@g
          ->

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index 0ba6e3f..8b88b9b 100644 (file)
--- a/GHC/HetMet/GArrow.hs
+++ b/GHC/HetMet/GArrow.hs
@@ -36,6 +36,7 @@ module GHC.HetMet.GArrow (
 
   GArrowKappa(..),
   GArrowSTKC(..),
+  GArrowSTKCL(..),
   GArrowSTLC(..),
   GArrowPCF(..)
 
@@ -107,8 +108,8 @@ ga_inr = ga_uncancell >>> ga_first  ga_never
 -- Loop
 
 class GArrow g (**) u => GArrowLoop g (**) u where
-  ga_loopl    :: g (x**z) (y**z) -> g x y
-  ga_loopr    :: g (z**x) (z**y) -> g x y
+  ga_loopr    :: g (x**z) (y**z) -> g x y
+  ga_loopl    :: g (z**x) (z**y) -> g x y
 
 
 ------------------------------------------------------------------------
@@ -215,6 +216,12 @@ class (GArrowDrop  g (GArrowTensor g) (GArrowUnit g),
        GArrowSwap  g (GArrowTensor g) (GArrowUnit g)) =>
        GArrowSTKC  g
 
+class (GArrowDrop  g (GArrowTensor g) (GArrowUnit g),
+       GArrowCopy  g (GArrowTensor g) (GArrowUnit g),
+       GArrowSwap  g (GArrowTensor g) (GArrowUnit g),
+       GArrowLoop  g (GArrowTensor g) (GArrowUnit g)) =>
+       GArrowSTKCL  g
+
 -- The simply typed LAMBDA calculus
 class (GArrowDrop  g (GArrowTensor g) (GArrowUnit g),
        GArrowCopy  g (GArrowTensor g) (GArrowUnit g),

diff --git a/GHC/HetMet/Private.hs b/GHC/HetMet/Private.hs
index 9308087..59bddbf 100644 (file)
--- a/GHC/HetMet/Private.hs
+++ b/GHC/HetMet/Private.hs
@@ -28,6 +28,8 @@ module GHC.HetMet.Private (
   pga_applyr,
   pga_curryl,
   pga_curryr,
+  pga_loopl,
+  pga_loopr,
   pga_kappa
 ) where
 import Control.Category ( (>>>) )
@@ -37,7 +39,7 @@ import GHC.HetMet.GArrow
 -------------------------------------------------------------------------
 -- Used internally by the compiler, subject to change without notice!!
 
-newtype PGArrow g x y = PGArrowD { unG :: GArrowSTKC g => g x y }
+newtype PGArrow g x y = PGArrowD { unG :: GArrowSTKCL g => g x y }
 
 pga_id        :: forall g x. PGArrow g x x
 pga_id        =  PGArrowD { unG = Control.Category.id }
@@ -75,3 +77,7 @@ pga_curryr    :: forall g x y z . PGArrow g (GArrowTensor g x y) z  ->  PGArrow
 pga_curryr    =  error "not implemented"
 pga_kappa     :: forall g x y . (g (GArrowUnit g) x -> g (GArrowUnit g) y) -> g x y
 pga_kappa     =  error "not implemented"
+pga_loopr     :: forall g x y z . PGArrow g (GArrowTensor g x z) (GArrowTensor g y z) -> PGArrow g x y
+pga_loopr f   =  PGArrowD { unG = ga_loopr $ unG f }
+pga_loopl     :: forall g x y z . PGArrow g (GArrowTensor g z x) (GArrowTensor g z y) -> PGArrow g x y
+pga_loopl f   =  PGArrowD { unG = ga_loopl $ unG f }