X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHetMet%2FGArrow.hs;h=e2dbf95d418d4a35d5df5936d990d6d93c397162;hb=11345faf37729b649dad0c052ee698d7080e40ee;hp=e981d9b744920900d1c5d18b7165aca1497c3a46;hpb=aacbf981df184f572660fab36530b2fe372cab27;p=ghc-base.git diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs index e981d9b..e2dbf95 100644 --- a/GHC/HetMet/GArrow.hs +++ b/GHC/HetMet/GArrow.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XRankNTypes -XMultiParamTypeClasses -XNoMonomorphismRestriction -XTypeOperators -XFunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses, TypeOperators, FunctionalDependencies, TypeFamilies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.HetMet.GArrow @@ -30,12 +30,18 @@ module GHC.HetMet.GArrow ( GArrowCurry(..), GArrowApply(..), + GArrowTensor, + GArrowUnit, + GArrowExponent, + GArrowSTKC(..), + GArrowSTKCL(..), GArrowSTLC(..), GArrowPCF(..) ) where -import Control.Category +import Control.Category hiding ((.)) +import Prelude hiding (id) ------------------------------------------------------------------------ -- The main GArrow class @@ -75,39 +81,25 @@ ga_swap_second f = ------------------------------------------------------------------------- --- Products, Coproducts, etc -class (GArrow g (**) u, - GArrow g (<*>) v) => - GArrowProd g (**) u (<*>) v +------------------------------------------------------------------------ +-- Products, Coproducts, etc - -- fundep: in any given context, (<*>) may serve as the - -- product for at most one GArrow - | (**) -> (<*>), - (<*>) -> v, v -> (<*>) where - ga_prod_copy :: g x (x<*>x) - ga_prod_drop :: g x v -class (GArrow g (**) u, - GArrow g (<+>) v) => - GArrowSum g (**) u (<+>) v +class (GArrowDrop g (<*>) u, + GArrowCopy g (<*>) u) => + GArrowProd g (<*>) u - -- fundep: in any given context, (<+>) may serve as the - -- coproduct for at most one GArrow - | (<+>) -> (**), - (<+>) -> v, v -> (<+>) where +class GArrow g (<+>) u => + GArrowSum g (<+>) u where ga_merge :: g (x<+>x) x - ga_never :: g v x + ga_never :: g u x --- Note to self: do not remove this type declaration; it ensures that if --- I fiddle with the GArrowSum fundeps and get them wrong (i.e. insufficient) --- I'll find out about it when compiling the base library. -ga_inl :: GArrowSum g (**) u (<+>) v => g x (x<+>y) +ga_inl :: GArrowSum g (<+>) u => g x (x<+>y) ga_inl = ga_uncancelr >>> ga_second ga_never -ga_inr :: GArrowSum g (**) u (<+>) v => g x (y<+>x) +ga_inr :: GArrowSum g (<+>) u => g x (y<+>x) ga_inr = ga_uncancell >>> ga_first ga_never @@ -115,8 +107,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 ------------------------------------------------------------------------ @@ -142,8 +134,10 @@ class GArrow g (**) u => GArrowConstant g (**) u t r where + + ------------------------------------------------------------------------ --- Reify and Reflect, which are "curried" versions +-- Reify and Reflect, which are "curried" versions of eval/const -- 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 @@ -157,6 +151,7 @@ class GArrow g (**) u => GArrowReflect g (**) u r q x y where + ------------------------------------------------------------------------ -- Apply and Curry @@ -171,6 +166,31 @@ class GArrow g (**) u => GArrowCurry g (**) u (~>) where + +------------------------------------------------------------------------ +-- Type Families + +-- +-- The GArrow and GArrow{Copy,Drop,Swap} classes brandish their tensor +-- and unit types; this is important because we might want to have +-- both "instance GArrow g X Y" and "instance GArrow g Z Q" -- in +-- fact, this is exactly how sums and pairs are defined. +-- +-- However, in daily practice it's a pain to have all those extra type +-- variables floating around. If you'd like to hide them, you can use +-- the type families below to do so; see the definition of class +-- GArrowSTKC for an example. Keep in mind, however, that any given +-- type may only have a single instance declared using the type +-- families. +-- + +type family GArrowTensor g :: * -> * -> * -- (**) +type family GArrowUnit g :: * -- () +type family GArrowExponent g :: * -> * -> * -- (~>) + + + + ------------------------------------------------------------------------ -- Commonly Implemented Collections of Classes @@ -179,27 +199,49 @@ class GArrow g (**) u => GArrowCurry g (**) u (~>) where -- Lambda Calculus into a Couple of Categorical Programming -- Languages__, http://dx.doi.org/10.1007/3-540-60164-3_28 -- -class (GArrowDrop g (**) u, - GArrowCopy g (**) u, - GArrowSwap g (**) u) => - GArrowSTKC g (**) u --- The simply typed LAMBDA calculus -class (GArrowSTKC g (**) u, - GArrowCurry g (**) u (~>), - GArrowApply g (**) u (~>)) => - GArrowSTLC g (**) u (~>) - --- Programming Language for Computable Functions (w/o integers and booleans) -class (GArrowSTLC g (**) u (~>), - GArrowLoop g (**) u) => - GArrowPCF g (**) u (~>) +class (GArrowDrop g (GArrowTensor g) (GArrowUnit g), + GArrowCopy 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), + GArrowSwap g (GArrowTensor g) (GArrowUnit g), + GArrowCurry g (GArrowTensor g) (GArrowUnit g) (GArrowExponent g), + GArrowApply g (GArrowTensor g) (GArrowUnit g) (GArrowExponent g) + ) => + GArrowSTLC g +-- Programming Language for Computable Functions (w/o integers and booleans) +class (GArrowDrop g (GArrowTensor g) (GArrowUnit g), + GArrowCopy g (GArrowTensor g) (GArrowUnit g), + GArrowSwap g (GArrowTensor g) (GArrowUnit g), + GArrowCurry g (GArrowTensor g) (GArrowUnit g) (GArrowExponent g), + GArrowApply g (GArrowTensor g) (GArrowUnit g) (GArrowExponent g), + GArrowLoop g (GArrowTensor g) (GArrowUnit g) + ) => + GArrowPCF g (**) u (~>) +------------------------------------------------------------------------ +-- Experimental, Not Yet Exported + +-- See Lindley, Wadler, and Yallop '08 -- except that here ga_force +-- is primitive since there is no "arr" to define it in terms of. +class GArrow g (**) u => GArrowStatic g (**) u (~>) where + ga_delay :: g a b -> g u (a~>b) + ga_force :: g u (a~>b) -> g a b + -- "ga_static/force_delay" forall a . force (delay a) = a + -- "ga_static/delay_force" forall a . delay (force a) = a