Lift & NDet

Alt.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE Safe                      #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}
module Control.Eff.Alt (
  Alt
  , left
  , right
  , makeChoiceA
  , runMaybe
  ) where

import           Control.Eff
import           Control.Eff.Exception
import           Control.Eff.Extend

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Base
import           Control.Monad.Trans.Control
import           Data.Function               (fix)

-- | See 'Control.Eff.Logic.NDet.NDet'
data Alt a where
  MZero :: Alt a
  MPlus :: Alt Bool

-- | The left branch
left :: Arrs r Bool a -> Eff r a
left q = q ^$ True

-- | The right branch
right :: Arrs r Bool a -> Eff r a
right q = q ^$ False

-- | I want to handle the effect using the Alternative instance of `m`
instance (Alternative m, Lifted m r) => Handle Alt r a k where
  handle step cor req = case req of
    MZero -> step (lift empty)
    MPlus -> 
      -- The following compiles but it is the wrong behaviour!
      -- 
      -- in particular, 'empty <|> pure a' results in 'empty'
      -- but it should evaluate to 'pure a'
      --
      -- seems like we need an `ap` for the `Arrs` type
      let ch = singleK $ \(l, r) -> lift (pure l <|> pure r)
          op = singleK $ \(l, r) -> (,) <$> l <*> r
      in
      step (op `comp` ch ^$ (left cor, right cor))

instance Member Alt r => Alternative (Eff r) where
  empty     = send MZero
  m1 <|> m2 = send MPlus >>= \x -> if x then m1 else m2

makeChoiceA :: (Alternative m, Lifted m r) => Eff (Alt ': r) a -> Eff r a
makeChoiceA = fix (handle_relay pure)

-- WRONG:
-- >>> runMaybe (empty <|> pure 10)
-- >>> Nothing
-- >>> runMaybe (pure 10 <|> empty)
-- >>> Nothing
--
runMaybe :: Eff '[Alt, Lift Maybe] a -> Maybe a
runMaybe = runLift . makeChoiceA

FreerSimple.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
-- Same idea as in 'NDetProblem', but this time using `freer-simple`
module FreerSimple where

import           Control.Applicative    (Alternative (..))
import           Control.Monad.Freer
import           Control.Monad.Freer.NonDet
import           Control.Monad          (join)

-- | An 'Either' that collects the 'Left' values
--   in its 'Applicative' and 'Alternative' instances
data Alt l r = AltL l | AltR r
    deriving (Eq, Ord, Show)

fromEither :: Either l r -> Alt l r
fromEither = either AltL AltR

toEither :: Alt l r -> Either l r
toEither (AltL l) = Left l
toEither (AltR r) = Right r

instance Functor (Alt l) where
    fmap _ (AltL l) = AltL l
    fmap f (AltR r) = AltR (f r)

instance Semigroup l => Applicative (Alt l) where
    pure = AltR
    AltR l <*> AltR r = AltR $ l r
    AltL l <*> AltR _ = AltL l
    AltR _ <*> AltL r = AltL r
    AltL l <*> AltL r = AltL $ l <> r

instance Monoid l => Alternative (Alt l) where
    empty = AltL mempty
    AltR l <|> _ = AltR l
    _      <|> AltR r = AltR r
    AltL l <|> AltL r = AltL $ l <> r

instance Semigroup l => Monad (Alt l) where
    AltR a >>= f = f a
    AltL l >>= _ = AltL l

-- >>> AltL "hello" <|> AltL "world"
-- >>> AltL "helloworld"
-- >>> run' (sendM (AltL "hello") <|> sendM (AltL "world"))
-- >>> AltL "hello"
run' :: Eff '[NonDet, Alt String] a -> Alt String a
run' = join . runM . makeChoiceA

NDetProblem.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
module NDetProblem where

import           Control.Applicative                             (Alternative (..))
import           Control.Eff
import           Control.Eff.Logic.NDet
import           Control.Monad                                   (join)

-- | An 'Either' that collects the 'Left' values
--   in its 'Applicative' and 'Alternative' instances
data Alt l r = AltL l | AltR r
    deriving (Eq, Ord, Show)

fromEither :: Either l r -> Alt l r
fromEither = either AltL AltR

toEither :: Alt l r -> Either l r
toEither (AltL l) = Left l
toEither (AltR r) = Right r

instance Functor (Alt l) where
    fmap _ (AltL l) = AltL l
    fmap f (AltR r) = AltR (f r)

instance Semigroup l => Applicative (Alt l) where
    pure = AltR
    AltR l <*> AltR r = AltR $ l r
    AltL l <*> AltR _ = AltL l
    AltR _ <*> AltL r = AltL r
    AltL l <*> AltL r = AltL $ l <> r

instance Monoid l => Alternative (Alt l) where
    empty = AltL mempty
    AltR l <|> _ = AltR l
    _      <|> AltR r = AltR r
    AltL l <|> AltL r = AltL $ l <> r

instance Semigroup l => Monad (Alt l) where
    AltR a >>= f = f a
    AltL l >>= _ = AltL l

-- >>> AltL "hello" <|> AltL "world"
-- >>> AltL "helloworld"
-- >>> run' (lift (AltL "hello") <|> lift (AltL "world"))
-- >>> AltL "hello"
run' :: Eff '[NDet, Lift (Alt String)] a -> Alt String a
run' = join . runLift . makeChoiceA