got rid of GAS_const and GAS_merge!!!! hooray!

[coq-hetmet.git] / examples / GArrowPortShape.hs

diff --git a/examples/GArrowPortShape.hs b/examples/GArrowPortShape.hs
index fe0ab58..5b4f5b6 100644 (file)
--- a/examples/GArrowPortShape.hs
+++ b/examples/GArrowPortShape.hs
@@ -19,11 +19,11 @@
 -- information for certain nodes (the inference mechanism below adds
 -- it on every node).
 --
-module GArrowPortShape (GArrowPortShape(..), PortShape(..), detectShape)
+module GArrowPortShape (GArrowPortShape(..), PortShape(..), detectShape, Detect(..), DetectM, freshM)
 where
 import Prelude hiding ( id, (.), lookup )
 import Control.Category
-import GHC.HetMet.GArrow
+import Control.GArrow
 import Unify
 import GArrowSkeleton
 import Control.Monad.State
@@ -118,9 +118,7 @@ resolveG u (GASPortShapeWrapper x y g) = GASPortShapeWrapper (getU' u x) (getU'
   resolveG' GAS_uncancell       = GAS_uncancell
   resolveG' GAS_uncancelr       = GAS_uncancelr
   resolveG' GAS_drop            = GAS_drop
-  resolveG' (GAS_const i)       = GAS_const i
   resolveG' GAS_copy            = GAS_copy
-  resolveG' GAS_merge           = GAS_merge
   resolveG' GAS_swap            = GAS_swap
   resolveG' GAS_assoc           = GAS_assoc
   resolveG' GAS_unassoc         = GAS_unassoc
@@ -128,16 +126,19 @@ resolveG u (GASPortShapeWrapper x y g) = GASPortShapeWrapper (getU' u x) (getU'
   resolveG' (GAS_loopr f)       = GAS_loopr (resolveG' f)
   resolveG' (GAS_misc g )       = GAS_misc $ resolveG u g
 
-detectShape :: GArrowSkeleton m a b -> GArrowPortShape m () a b
+detectShape :: Detect m => GArrowSkeleton m a b -> GArrowPortShape m () a b
 detectShape g = runM (detect g)
 
-runM :: DetectM (GArrowPortShape m UVar a b) -> GArrowPortShape m () a b
+runM :: Detect m => DetectM (GArrowPortShape m UVar a b) -> GArrowPortShape m () a b
 runM f = let s     = (emptyUnifier,uvarSupply)
              g     = evalState f s
              (u,_) = execState f s
           in resolveG u g
 
-detect :: GArrowSkeleton m a b -> DetectM (GArrowPortShape m UVar a b)
+class Detect m where
+  detect' :: m x y -> DetectM (GArrowPortShape m UVar x y)
+
+detect :: Detect m => GArrowSkeleton m a b -> DetectM (GArrowPortShape m UVar a b)
 detect (GAS_id      ) = do { x <- freshM ; return $ GASPortShapeWrapper (PortFree x) (PortFree x) GAS_id }
 detect (GAS_comp f g) = do { f' <- detect f
                            ; g' <- detect g
@@ -189,11 +190,6 @@ detect GAS_unassoc    = do { x <- freshM; y <- freshM; z <- freshM
                                         (PortTensor (PortTensor x' y') z')
                                         GAS_unassoc
                            }
-detect (GAS_const i)  = do { x <- freshM; return $ GASPortShapeWrapper PortUnit (PortFree x) (GAS_const i) }
-
-detect GAS_merge      = do { x <- freshM
-                           ; return $ GASPortShapeWrapper (PortTensor (PortFree x) (PortFree x)) (PortFree x) GAS_merge }
-
 detect (GAS_loopl f)  = do { x <- freshM
                            ; y <- freshM
                            ; z <- freshM
@@ -211,5 +207,5 @@ detect (GAS_loopr f)  = do { x <- freshM
                            ; return $ GASPortShapeWrapper (PortFree x) (PortFree y) (GAS_loopr (GAS_misc f'))
                            }
 
-detect (GAS_misc f)   = error "GAS_misc: not implemented"
+detect (GAS_misc f)   = detect' f