[GHC] #13026: RFC functions for sums and products

[GHC]

#13026: RFC functions for sums and products
-------------------------------------+-------------------------------------
        Reporter:  Iceland_jack      |                Owner:
            Type:  feature request   |               Status:  new
        Priority:  normal            |            Milestone:
       Component:  libraries/base    |              Version:  8.0.1
      Resolution:                    |             Keywords:
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by Iceland_jack):

 Stolen from `Data.Tuple`, I have never needed them but who knows

 {{{#!hs
 fst' :: Product f g ~> f
 fst' (Pair fa _) = fa

 snd' :: Product f g ~> g
 snd' (Pair _ ga) = ga

 curry' :: (Product f g ~> h) -> (forall a. f a -> g a -> h a)
 curry' nat fa ga = nat (Pair fa ga)

 uncurry' :: (forall a. f a -> g a -> h a) -> (Product f g ~> h)
 uncurry' f (Pair fa ga) = f fa ga

 swap' :: Product f g ~> Product g f
 swap' (Pair fa ga) = Pair ga fa
 }}}

 and from `Data.Either`

 {{{#!hs
 lefts' :: [(Sum f g) a] -> [f a]
 lefts' sums = [ fa | InL fa <- sums ]

 rights' :: [(Sum f g) a] -> [g a]
 rights' sums = [ ga | InR ga <- sums ]

 isInL :: Sum f g a -> Bool
 isInL InL{} = True
 isInL _     = False

 isInR :: Sum f g a -> Bool
 isInR InR{} = True
 isInR _     = False

 sum' :: (f a -> c) -> (g a -> c) -> (Sum f g a -> c)
 sum' f _ (InL x)    =  f x
 sum' _ g (InR y)    =  g y

 partitionSums :: [Sum f g a] -> ([f a], [g a])
 partitionSums = foldr (sum' left right) ([], [])
  where
    left  a ~(l, r) = (a:l, r)
    right a ~(l, r) = (l, a:r)
 }}}

 With the `lens` vocabulary we could write

 {{{#!hs
 _InL :: Prism (Sum f g a) (Sum f' g a) (f a) (f' a)
 _InL = prism
   InL
   (\case
     InL fa -> Right fa
     InR ga -> Left (InR ga))

 _InR :: Prism (Sum f g a) (Sum f g' a) (g a) (g' a)
 _InR = prism
   InR
   (\case
     InR ga -> Right ga
     InL fa -> Left (InL fa))

 instance Field1 (Product f g a) (Product f' g a) (f a) (f' a) where
   _1 :: Lens (Product f g a) (Product f' g a) (f a) (f' a)
   _1 = lens
     fst'
     (\(Pair _ ga) fa -> Pair fa ga)

 instance Field2 (Product f g a) (Product f g' a) (g a) (g' a) where
   _2 :: Lens (Product f g a) (Product f g' a) (g a) (g' a)
   _2 = lens
     snd'
     (\(Pair fa _) ga -> Pair fa ga)
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/13026#comment:3>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler