From f98950484a7cb01e43352e3d88277a2784cd58bf Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Mon, 21 Mar 2011 18:24:38 -0700 Subject: [PATCH] final revision to GArrow classes --- GHC/HetMet/Arrow.hs | 22 +++++---- GHC/HetMet/GArrow.hs | 106 +++++++++++++++++++++++++++++++---------- GHC/HetMet/GArrowInstances.hs | 27 +++++++++++ base.cabal | 1 + 4 files changed, 122 insertions(+), 34 deletions(-) create mode 100644 GHC/HetMet/GArrowInstances.hs diff --git a/GHC/HetMet/Arrow.hs b/GHC/HetMet/Arrow.hs index 8352c78..5bead2c 100644 --- a/GHC/HetMet/Arrow.hs +++ b/GHC/HetMet/Arrow.hs @@ -20,7 +20,9 @@ import Control.Category -- algorithm often creates overlapping or even undecidable -- instance-search problems -instance Arrow a => GArrow a (,) where +type Id a = a + +instance Arrow a => GArrow a (,) () where ga_first = first ga_second = second ga_cancell = arr (\((),x) -> x) @@ -30,24 +32,28 @@ instance Arrow a => GArrow a (,) where ga_assoc = arr (\((x,y),z) -> (x,(y,z))) ga_unassoc = arr (\(x,(y,z)) -> ((x,y),z)) -instance Arrow a => GArrowDrop a (,) where +instance Arrow a => GArrowDrop a (,) () where ga_drop = arr (\x -> ()) -instance Arrow a => GArrowCopy a (,) where +instance Arrow a => GArrowCopy a (,) () where ga_copy = arr (\x -> (x,x)) -instance Arrow a => GArrowSwap a (,) where +instance Arrow a => GArrowSwap a (,) () where ga_swap = arr (\(x,y) -> (y,x)) -instance Arrow a => GArrowConstant a (,) where +instance Arrow a => GArrowConstant a (,) () t t where ga_constant x = arr (\() -> x) -instance Arrow a => GArrowReify a (,) where +instance Arrow a => GArrowReify a (,) () x y x y where ga_reify = arr -instance ArrowLoop a => GArrowLoop a (,) where - ga_loop = loop +instance ArrowLoop a => GArrowLoop a (,) () where + ga_loopl = loop + ga_loopr f = loop (ga_swap >>> f >>> ga_swap) +instance ArrowApply a => GArrowApply a (,) () a where + ga_applyl = ga_swap >>> app + ga_applyr = app diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs index 9b15116..d55a807 100644 --- a/GHC/HetMet/GArrow.hs +++ b/GHC/HetMet/GArrow.hs @@ -14,40 +14,50 @@ module GHC.HetMet.GArrow ( GArrowDrop(..), GArrowCopy(..), GArrowSwap(..), + GArrowLoop(..), + + GArrowEval(..), GArrowConstant(..), - GArrowRun(..), + GArrowLiteral(..), -- should be implemented, but never invoked, by user code + + GArrowSum(..), + GArrowProd(..), + GArrowReify(..), - GArrowReflect(..) + GArrowReflect(..), + + GArrowCurry(..), + GArrowApply(..) ) where import Control.Category ------------------------------------------------------------------------ -- The main GArrow class -class Category g => GArrow g (**) | g -> (**) where +class Category g => GArrow g (**) u | (**) -> u where --id :: g x x --comp :: g x y -> g y z -> g x z ga_first :: g x y -> g (x ** z) (y ** z) ga_second :: g x y -> g (z ** x) (z ** y) - ga_cancell :: g (()**x) x - ga_cancelr :: g (x**()) x - ga_uncancell :: g x (()**x) - ga_uncancelr :: g x (x**()) - ga_assoc :: g ((x**y)**z) (x**(y**z)) - ga_unassoc :: g (x**(y**z)) ((x**y)**z) + ga_cancell :: g (u**x) x + ga_cancelr :: g (x**u) x + ga_uncancell :: g x (u**x) + ga_uncancelr :: g x (x**u) + ga_assoc :: g ((x** y)**z ) ( x**(y **z)) + ga_unassoc :: g ( x**(y **z)) ((x** y)**z ) ------------------------------------------------------------------------ -- The three context-manipulation classes -class GArrow g (**) => GArrowCopy g (**) where +class GArrow g (**) u => GArrowCopy g (**) u where ga_copy :: g x (x**x) -class GArrow g (**) => GArrowDrop g (**) where - ga_drop :: g x () +class GArrow g (**) u => GArrowDrop g (**) u where + ga_drop :: g x u -class GArrow g (**) => GArrowSwap g (**) where +class GArrow g (**) u => GArrowSwap g (**) u where ga_swap :: g (x**y) (y**x) ga_swap_second f = @@ -61,34 +71,78 @@ ga_swap_second f = ------------------------------------------------------------------------ +-- Products, Coproducts, etc + + +class (GArrow g (**) u, + GArrow g (<*>) u) => + GArrowProd g (**) u (<*>) where + ga_prod_copy :: g x (x<*>x) + ga_prod_drop :: g x u + +class (GArrow g (**) u, + GArrow g (<+>) v) => + GArrowSum g (**) u v (<+>) where + ga_merge :: g (x**x) x + ga_never :: g v x + + + + + +------------------------------------------------------------------------ -- Loop -class GArrow g (**) => GArrowLoop g (**) where - ga_loop :: g (x**z) (y**z) -> g x y +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 + + +------------------------------------------------------------------------ +-- Literal. Note that ga_literal should never appear in (unflattened) +-- Haskell programs, though the user may wish to write implementations +-- of this function (I haven't yet found a way to enforce this +-- restriction using exports) + +class GArrow g (**) u => GArrowLiteral g (**) u t r where + ga_literal :: t -> g u r + ------------------------------------------------------------------------ -- Constant and Run, which are dual to each other -class GArrow g (**) => GArrowConstant g (**) where - ga_constant :: a -> g () a +class GArrow g (**) u => GArrowEval g (**) u r t where + ga_eval :: g u r -> t --- the dual of GArrowConstant -class GArrow g (**) => GArrowRun g (**) where - ga_run :: g () a -> a +class GArrow g (**) u => GArrowConstant g (**) u t r where + ga_constant :: t -> g u r ------------------------------------------------------------------------ -- Reify and Reflect, which are "curried" versions --- Not sure -- subject to change. If you have this, you're basically +-- If you have this for R the identity map on types, you're basically -- a Control.Arrow; you can also define essentially all the other -- methods of GArrow, GArrowDrop, GArrowCopy, etc in terms of this. -class GArrow g (**) => GArrowReify g (**) where - ga_reify :: (x -> y) -> g x y +class GArrow g (**) u => GArrowReify g (**) u x y r q where + ga_reify :: (x -> y) -> g r q + +class GArrow g (**) u => GArrowReflect g (**) u r q x y where + ga_reflect :: g r q -> (x -> y) + + + + +------------------------------------------------------------------------ +-- Apply and Curry + +class GArrow g (**) u => GArrowApply g (**) u (~>) where + ga_applyl :: g (x**(x~>y) ) y + ga_applyr :: g ( (x~>y)**x) y --- not sure -- subject to change -class GArrow g (**) => GArrowReflect g (**) where - ga_reflect :: g x y -> (x -> y) +class GArrow g (**) u => GArrowCurry g (**) u (~>) where + ga_curryl :: g x (y**(x~>y) ) + ga_curryr :: g x ( (x~>y)**y) diff --git a/GHC/HetMet/GArrowInstances.hs b/GHC/HetMet/GArrowInstances.hs new file mode 100644 index 0000000..0292d38 --- /dev/null +++ b/GHC/HetMet/GArrowInstances.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFlexibleInstances -XFunctionalDependencies #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.HetMet.GArrowInstances +-- Copyright : none +-- License : public domain +-- +-- Maintainer : Adam Megacz +-- Stability : experimental +-- Portability : portable + +module GHC.HetMet.GArrowInstances ( +) where +import Control.Category +import GHC.HetMet.GArrow + +-- Various GArrow instances which may confuse the instance-inference +-- mechanism if imported wholesale + + +-- If a GArrow offers constants, then Haskell literals can be used to +-- accomplish a GArrowLiteral implementation (the converse is not +-- true!) +--instance GArrowConstant g (**) u r t => GArrowLiteral g (**) u r t where +-- ga_literal = ga_constant + + diff --git a/base.cabal b/base.cabal index 80a0dbc..8e49e32 100644 --- a/base.cabal +++ b/base.cabal @@ -59,6 +59,7 @@ Library { GHC.HetMet, GHC.HetMet.CodeTypes, GHC.HetMet.GArrow, + GHC.HetMet.GArrowInstances, GHC.HetMet.Arrow, GHC.MVar, GHC.IO, -- 1.7.10.4