Selecting.hs

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
module Selecting where

import           Control.Applicative (liftA2)
import           Control.Selective   (Selective (..), ifS, selectM)
import           Data.Proxy
import           GHC.Generics

import           Test.QuickCheck

-------------------------------------------------------------------------------
-- selecting
-------------------------------------------------------------------------------

-- compare with deciding in
-- https://hackage.haskell.org/package/contravariant-1.5.5/docs/Data-Functor-Contravariant-Generic.html

selecting
    :: (Selective f, Generic a, GSelecting c (Rep a))
    => Proxy c
    -> f Bool
    -> (forall x. c x => f x)
    -> f a
selecting c b l = to <$> gselecting c b l

class GSelecting c a where
    gselecting :: Selective f => Proxy c -> f Bool -> (forall x. c x => f x) -> f (a y)

instance GSelectingS c a => GSelecting c (M1 i d a) where
    gselecting c b l = M1 <$> gselectingS c b l

-- sums
class GSelectingS c a where
    gselectingS :: Selective f => Proxy c -> f Bool -> (forall x. c x => f x) -> f (a y)

instance (GSelectingS c a, GSelectingS c b) => GSelectingS c (a :+: b) where
    gselectingS c b l = ifS b (L1 <$> gselectingS c b l) (R1 <$> gselectingS c b l)

-- products
class GSelectingP c a where
    gselectingP :: Selective f => Proxy c -> f Bool -> (forall x. c x => f x) -> f (a y)

instance GSelectingP c a => GSelectingS c (M1 i d a) where
    gselectingS c b l = M1 <$> gselectingP c b l

instance (GSelectingP c a, GSelectingP c b) => GSelectingP c (a :*: b) where
    gselectingP c b l = liftA2 (:*:) (gselectingP c b l) (gselectingP c b l)

-- leaves
class GSelectingL c a where
    gselectingL :: Selective f => Proxy c -> f Bool -> (forall x. c x => f x) -> f (a y)

instance GSelectingL c a => GSelectingP c (M1 i d a) where
    gselectingP c b l = M1 <$> gselectingL c b l

instance (c a, r ~ R) => GSelectingL c (K1 r a) where
    gselectingL _ _ p = K1 <$> p

-------------------------------------------------------------------------------
-- example
-------------------------------------------------------------------------------

instance Selective Gen where
    select = selectM -- we cannot really do better with QuickCheck

data Demo
    = Demo1 Int Char
    | Demo2 Bool String
  deriving (Show, Generic)

instance Arbitrary Demo where
    arbitrary = selecting (Proxy @Arbitrary) arbitrary arbitrary

demo :: IO ()
demo = sample (arbitrary :: Gen Demo)