move the (Arrow a)=>(GArrow a (,)) instance to a separate file

diff --git a/GHC/HetMet/Arrow.hs b/GHC/HetMet/Arrow.hs
new file mode 100644 (file)
index 0000000..39bd2fe
--- /dev/null
+++ b/GHC/HetMet/Arrow.hs
@@ -0,0 +1,56 @@
+{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.HetMet.Arrow
+-- Copyright   :  none
+-- License     :  public domain
+--
+-- Maintainer  :  Adam Megacz <megacz@acm.org>
+-- Stability   :  experimental
+-- Portability :  portable
+
+module GHC.HetMet.Arrow where
+import GHC.HetMet.GArrow
+import Control.Arrow
+import Control.Category
+
+------------------------------------------------------------------------------
+-- GArrow instances for Control.Arrow; this is kept in a separate
+-- module because having it available to GHC's instance-search
+-- algorithm often creates overlapping or even undecidable
+-- instance-search problems
+
+instance Arrow a => GArrow a (,) where
+  ga_first     =  first
+  ga_second    =  second
+  ga_cancell   =  arr (\((),x) -> x)
+  ga_cancelr   =  arr (\(x,()) -> x)
+  ga_uncancell =  arr (\x -> ((),x))
+  ga_uncancelr =  arr (\x -> (x,()))
+  ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
+  ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
+  
+instance Arrow a => GArrowDrop a (,) where
+  ga_drop      =  arr (\x -> ())
+
+instance Arrow a => GArrowCopy a (,) where
+  ga_copy      =  arr (\x -> (x,x))
+
+instance Arrow a => GArrowSwap a (,) where
+  ga_swap      =  arr (\(x,y) -> (y,x))
+
+instance Arrow a => GArrowLiteral a (,) b where
+  ga_literal x = arr (\() -> x)
+
+instance Arrow a => GArrowReify a (,) where
+  ga_reify     =  arr
+
+instance ArrowLoop a => GArrowLoop a (,) where
+  ga_loop      =  loop
+
+
+
+
+
+
+

diff --git a/GHC/HetMet/CodeTypes.hs b/GHC/HetMet/CodeTypes.hs
index cf0dc12..82a6d01 100644 (file)
--- a/GHC/HetMet/CodeTypes.hs
+++ b/GHC/HetMet/CodeTypes.hs
@@ -44,15 +44,23 @@ hetmet_flatten ::
 hetmet_flatten _ = Prelude.error "hetmet_flatten should never be evaluated; did you forget to compile with -fcoqpass?"
 -}
 
+
+-- FIXME: move these and the three above to "prim" or something like that.
+
+-- Technically these functions ought to be invoked *during
+-- compilation*; in the future I would like to use Template Haskell to
+-- do that.
 class GuestIntegerLiteral c where
   guestIntegerLiteral :: Integer -> <[ Integer ]>@c
-
 class GuestStringLiteral c where
   guestStringLiteral :: String -> <[ String ]>@c
-
 class GuestCharLiteral c where
   guestCharLiteral :: Char -> <[ Char ]>@c
 
+
+class GuestLanguageConstant c t where
+  guestLanguageConstant :: t -> <[ t ]>@c
+
 -- Note that stringwise-identical identifiers at different syntactic
 -- depths are different identifiers; for this reason the operators
 -- below can have a different type at syntactical depth 1 than at

diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs
index 9853637..e1ac446 100644 (file)
--- a/GHC/HetMet/GArrow.hs
+++ b/GHC/HetMet/GArrow.hs
@@ -16,9 +16,9 @@ module GHC.HetMet.GArrow (
   GArrowSwap(..),
   GArrowLoop(..),
   GArrowReify(..),
-  GArrowReflect(..)
+  GArrowReflect(..),
+  GArrowLiteral(..)
 ) where
-import Control.Arrow
 import Control.Category
 
 class Category g => GArrow g (**) | g -> (**) where
@@ -57,39 +57,3 @@ class GArrow g (**) => GArrowReify g (**) where
 class GArrow g (**) => GArrowReflect g (**) where
   ga_reflect   :: g x y -> (x -> y)
 
-
-
-------------------------------------------------------------------------------
--- GArrow instances for Control.Arrow
-
-instance Arrow a => GArrow a (,) where
-  ga_first     =  first
-  ga_second    =  second
-  ga_cancell   =  arr (\((),x) -> x)
-  ga_cancelr   =  arr (\(x,()) -> x)
-  ga_uncancell =  arr (\x -> ((),x))
-  ga_uncancelr =  arr (\x -> (x,()))
-  ga_assoc     =  arr (\((x,y),z) -> (x,(y,z)))
-  ga_unassoc   =  arr (\(x,(y,z)) -> ((x,y),z))
-  
-instance Arrow a => GArrowDrop a (,) where
-  ga_drop      =  arr (\x -> ())
-
-instance Arrow a => GArrowCopy a (,) where
-  ga_copy      =  arr (\x -> (x,x))
-
-instance Arrow a => GArrowSwap a (,) where
-  ga_swap      =  arr (\(x,y) -> (y,x))
-
-instance Arrow a => GArrowLiteral a (,) b where
-  ga_literal x =  arr (\() -> x)
-
-instance Arrow a => GArrowReify a (,) where
-  ga_reify     =  arr
-
-instance ArrowLoop a => GArrowLoop a (,) where
-  ga_loop      =  loop
-
-
-
-

diff --git a/base.cabal b/base.cabal
index d799867..80a0dbc 100644 (file)
--- a/base.cabal
+++ b/base.cabal
@@ -59,6 +59,7 @@ Library {
             GHC.HetMet,
             GHC.HetMet.CodeTypes,
             GHC.HetMet.GArrow,
+            GHC.HetMet.Arrow,
             GHC.MVar,
             GHC.IO,
             GHC.IO.IOMode,