From: Adam Megacz <megacz@cs.berkeley.edu>
Date: Thu, 5 May 2011 03:18:40 +0000 (-0700)
Subject: add first draft of GHC.HetMet.Private
X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=610eba115e62d65c7b87d689cbd2fee24cd32dad

add first draft of GHC.HetMet.Private
---

diff --git a/GHC/HetMet/Private.hs b/GHC/HetMet/Private.hs
new file mode 100644
index 0000000..aee3ad6
--- /dev/null
+++ b/GHC/HetMet/Private.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE RankNTypes, ScopedTypeVariables, NoMonomorphismRestriction, TypeOperators, FunctionalDependencies, FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.HetMet.GArrow
+-- Copyright   :  none
+-- License     :  public domain
+--
+-- Maintainer  :  Adam Megacz <megacz@acm.org>
+-- Stability   :  experimental
+-- Portability :  portable
+
+module GHC.HetMet.Private (
+  PGArrow,
+  pga_id,
+  pga_comp,
+  pga_first,
+  pga_second,
+  pga_cancell,
+  pga_cancelr,
+  pga_uncancell,
+  pga_uncancelr,
+  pga_assoc,
+  pga_unassoc,
+  pga_copy,
+  pga_drop,
+  pga_swap,
+  pga_applyl,
+  pga_applyr,
+  pga_curryl,
+  pga_curryr
+) where
+import Control.Category ( (>>>) )
+import qualified Control.Category
+import GHC.HetMet.GArrow
+
+-------------------------------------------------------------------------
+-- Used internally by the compiler, subject to change without notice!!
+
+newtype PGArrow x y = PGArrow { unG :: forall g. GArrowSTKC g (,) () => g x y }
+
+pga_id        :: PGArrow x x
+pga_id        =  PGArrow { unG = Control.Category.id }
+pga_comp      :: forall x y z. PGArrow x y -> PGArrow y z -> PGArrow x z
+pga_comp f g  =  PGArrow { unG = unG f >>> unG g }
+pga_first     :: PGArrow x y -> PGArrow (x , z) (y , z)
+pga_first f   =  PGArrow { unG = ga_first $ unG f }
+pga_second    :: PGArrow x y -> PGArrow (z , x) (z , y)
+pga_second f  =  PGArrow { unG = ga_second $ unG f }
+pga_cancell   :: PGArrow ((),x)         x
+pga_cancell   =  PGArrow { unG = ga_cancell }
+pga_cancelr   :: PGArrow    (x,())      x
+pga_cancelr   =  PGArrow { unG = ga_cancelr }
+pga_uncancell :: PGArrow     x      ((),x)
+pga_uncancell =  PGArrow { unG = ga_uncancell }
+pga_uncancelr :: PGArrow     x         (x,())
+pga_uncancelr =  PGArrow { unG = ga_uncancelr }
+pga_assoc     :: PGArrow ((x, y),z ) ( x,(y ,z))
+pga_assoc     =  PGArrow { unG = ga_assoc }
+pga_unassoc   :: PGArrow ( x,(y ,z)) ((x, y),z )
+pga_unassoc   =  PGArrow { unG = ga_unassoc }
+pga_copy      :: PGArrow x (x,x)
+pga_copy      =  PGArrow { unG = ga_copy }
+pga_drop      :: PGArrow x ()
+pga_drop      =  PGArrow { unG = ga_drop }
+pga_swap      :: PGArrow (x,y) (y,x)
+pga_swap      =  PGArrow { unG = ga_swap }
+pga_applyl    :: PGArrow (x,(x->y)   ) y
+pga_applyl    =  error "not implemented"
+pga_applyr    :: PGArrow (   (x->y),x) y
+pga_applyr    =  error "not implemented"
+pga_curryl    :: PGArrow (x,y) z  ->  PGArrow x (y->z)
+pga_curryl    =  error "not implemented"
+pga_curryr    :: PGArrow (x,y) z  ->  PGArrow y (x->z)
+pga_curryr    =  error "not implemented"
diff --git a/base.cabal b/base.cabal
index 8e49e32..628b992 100644
--- a/base.cabal
+++ b/base.cabal
@@ -60,6 +60,7 @@ Library {
             GHC.HetMet.CodeTypes,
             GHC.HetMet.GArrow,
             GHC.HetMet.GArrowInstances,
+            GHC.HetMet.Private,
             GHC.HetMet.Arrow,
             GHC.MVar,
             GHC.IO,