From 9519dc947bc926df91c7921d623ac93a6517e008 Mon Sep 17 00:00:00 2001 From: Adam Megacz Date: Sat, 16 Apr 2011 14:56:43 -0700 Subject: [PATCH] rephrase GArrow{Sum,Prod} to make instance inference easier --- GHC/HetMet/Arrow.hs | 6 ++---- GHC/HetMet/GArrow.hs | 34 +++++++++------------------------- 2 files changed, 11 insertions(+), 29 deletions(-) diff --git a/GHC/HetMet/Arrow.hs b/GHC/HetMet/Arrow.hs index 2de4c42..cb20a6a 100644 --- a/GHC/HetMet/Arrow.hs +++ b/GHC/HetMet/Arrow.hs @@ -55,9 +55,7 @@ instance ArrowApply a => GArrowApply a (,) () a where ga_applyl = ga_swap >>> app ga_applyr = app -instance Arrow a => GArrowProd a (,) () (,) () where - ga_prod_drop = arr (\x -> ()) - ga_prod_copy = arr (\x -> (x,x)) +instance Arrow a => GArrowProd a (,) () where -- The uninhabited type data Void @@ -90,7 +88,7 @@ instance ArrowChoice a => GArrow a Either Void where eitherUnAssoc (Right (Left y)) = Left (Right y) eitherUnAssoc (Right (Right z)) = Right z -instance ArrowChoice a => GArrowSum a (,) () Either Void where +instance ArrowChoice a => GArrowSum a Either Void where ga_never = arr voidImpossible ga_merge = arr merge where diff --git a/GHC/HetMet/GArrow.hs b/GHC/HetMet/GArrow.hs index e981d9b..c340fe2 100644 --- a/GHC/HetMet/GArrow.hs +++ b/GHC/HetMet/GArrow.hs @@ -79,35 +79,19 @@ ga_swap_second f = -- Products, Coproducts, etc -class (GArrow g (**) u, - GArrow g (<*>) v) => - GArrowProd g (**) u (<*>) v - - -- 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 - - -- fundep: in any given context, (<+>) may serve as the - -- coproduct for at most one GArrow - | (<+>) -> (**), - (<+>) -> v, v -> (<+>) where +class (GArrowDrop g (<*>) u, + GArrowCopy g (<*>) u) => + GArrowProd g (<*>) u + +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 -- 1.7.10.4