Internal.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- The following is needed to define MonadPlus instance. It is decidable
-- (there is no recursion!), but GHC cannot see that.
--
-- TODO: Remove once GHC can deduce the decidability of this instance.
{-# LANGUAGE UndecidableInstances #-}

-- Due to re-export of Data.FTCQueue, and Data.OpenUnion.
{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}

-- |
-- Module:       Control.Monad.Freer.Internal
-- Description:  Mechanisms to make effects work.
-- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
-- License:      BSD3
-- Maintainer:   ixcom-core@ixperta.com
-- Stability:    experimental
-- Portability:  GHC specific language extensions.
--
-- Internal machinery for this effects library. This includes:
--
-- * 'Eff' data type, for expressing effects.
-- * 'NonDet' data type, for nondeterministic effects.
-- * Functions for facilitating the construction of effects and their handlers.
--
-- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
module Control.Monad.Freer.Internal
    (
    -- * Effect Monad
      Eff(..)
    , Arr
    , Arrs

    -- ** Open Union
    --
    -- | Open Union (type-indexed co-product) of effects.
    , module Data.OpenUnion

    -- ** Fast Type-aligned Queue
    --
    -- | Fast type-aligned queue optimized to effectful functions of type
    -- @(a -> m b)@.
    , module Data.FTCQueue

    -- ** Sending Arbitrary Effect
    , send

    -- * Handling Effects
    , run
    , runM

    -- ** Building Effect Handlers
    , handleRelay
    , handleRelayS
    , interpose

    -- *** Low-level Functions for Building Effect Handlers
    , qApp
    , qComp

    -- ** Nondeterminism Effect
    , NonDet(..)
    )
  where

import Prelude (error)  -- Function error is used for imposible cases.

import Control.Applicative
    ( Alternative((<|>), empty)
    , Applicative((<*>), pure)
    )
import Control.Monad
    ( Monad((>>=), return)
    , MonadPlus(mplus, mzero)
    )
import Data.Bool (Bool)
import Data.Either (Either(Left, Right))
import Data.Function (($), (.))
import Data.Functor (Functor(fmap))
import Data.Maybe (Maybe(Just))

import Data.FTCQueue
import Data.OpenUnion


-- | Effectful arrow type: a function from @a :: *@ to @b :: *@ that also does
-- effects denoted by @effs :: [* -> *]@.
type Arr effs a b = a -> Eff effs b

-- | An effectful function from @a :: *@ to @b :: *@ that is a composition of
-- several effectful functions. The paremeter @eff :: [* -> *]@ describes the
-- overall effect. The composition members are accumulated in a type-aligned
-- queue.
type Arrs effs a b = FTCQueue (Eff effs) a b

-- | The Eff monad provides a way to use effects in Haskell, in such a way that
-- different types of effects can be interleaved, and so that the produced code
-- is efficient.
data Eff effs a
    = Val a
    -- ^ Pure value (@'return' = 'pure' = 'Val'@).
    | forall b. E (Union effs b) (Arrs effs b a)
    -- ^ Sending a request of type @Union effs@ with the continuation
    -- @'Arrs' r b a@.

-- | Function application in the context of an array of effects,
-- @'Arrs' effs b w@.
qApp :: Arrs effs b w -> b -> Eff effs w
qApp q' x = case tviewl q' of
    TOne k  -> k x
    k :| t -> case k x of
        Val y -> qApp t y
        E u q -> E u (q >< t)

-- | Composition of effectful arrows ('Arrs'). Allows for the caller to change
-- the effect environment, as well.
qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp g h a = h $ qApp g a

instance Functor (Eff effs) where
    fmap f (Val x) = Val (f x)
    fmap f (E u q) = E u (q |> (Val . f))
    {-# INLINE fmap #-}

instance Applicative (Eff effs) where
    pure = Val
    {-# INLINE pure #-}

    Val f <*> Val x = Val $ f x
    Val f <*> E u q = E u (q |> (Val . f))
    E u q <*> Val x = E u (q |> (Val . ($ x)))
    E u q <*> m     = E u (q |> (`fmap` m))
    {-# INLINE (<*>) #-}

instance Monad (Eff effs) where
    -- Future versions of GHC will consider any other definition as error.
    return = pure
    {-# INLINE return #-}

    Val x >>= k = k x
    E u q >>= k = E u (q |> k)
    {-# INLINE (>>=) #-}

-- | Send a request and wait for a reply.
send :: Member eff effs => eff a -> Eff effs a
send t = E (inj t) (tsingleton Val)

--------------------------------------------------------------------------------
                       -- Base Effect Runner --
--------------------------------------------------------------------------------

-- | Runs a set of Effects. Requires that all effects are consumed.
-- Typically composed as follows:
--
-- @
-- 'run' . runEff1 eff1Arg . runEff2 eff2Arg1 eff2Arg2 $ someProgram
-- @
run :: Eff '[] a -> a
run (Val x) = x
run _       = error "Internal:run - This (E) should never happen"

-- | Runs a set of Effects. Requires that all effects are consumed, except for
-- a single effect known to be a monad. The value returned is a computation in
-- that monad. This is useful for plugging in traditional transformer stacks.
runM :: Monad m => Eff '[m] a -> m a
runM (Val x) = return x
runM (E u q) = case extract u of
    mb -> mb >>= runM . qApp q
    -- The other case is unreachable since Union [] a cannot be constructed.
    -- Therefore, run is a total function if its argument terminates.

-- | Given a request, either handle it or relay it.
handleRelay
    :: (a -> Eff effs b)
    -- ^ Handle a pure value.
    -> (forall v. eff v -> Arr effs v b -> Eff effs b)
    -- ^ Handle a request for effect of type @eff :: * -> *@.
    -> Eff (eff ': effs) a
    -> Eff effs b
    -- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelay ret h = loop
  where
    loop (Val x)  = ret x
    loop (E u' q) = case decomp u' of
        Right x -> h x k
        Left  u -> E u (tsingleton k)
      where
        k = qComp q loop

-- | Parameterized 'handleRelay'. Allows sending along some state of type
-- @s :: *@ to be handled for the target effect, or relayed to a handler that
-- can- handle the target effect.
handleRelayS
    :: s
    -> (s -> a -> Eff effs b)
    -- ^ Handle a pure value.
    -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
    -- ^ Handle a request for effect of type @eff :: * -> *@.
    -> Eff (eff ': effs) a
    -> Eff effs b
    -- ^ Result with effects of type @eff :: * -> *@ handled.
handleRelayS s' ret h = loop s'
  where
    loop s (Val x)  = ret s x
    loop s (E u' q) = case decomp u' of
        Right x -> h s x k
        Left  u -> E u (tsingleton (k s))
      where
        k s'' x = loop s'' $ qApp q x

-- | Intercept the request and possibly reply to it, but leave it unhandled.
interpose
    :: Member eff effs
    => (a -> Eff effs b)
    -> (forall v. eff v -> Arr effs v b -> Eff effs b)
    -> Eff effs a
    -> Eff effs b
interpose ret h = loop
  where
    loop (Val x) = ret x
    loop (E u q) = case prj u of
        Just x -> h x k
        _      -> E u (tsingleton k)
      where
        k = qComp q loop

--------------------------------------------------------------------------------
                    -- Nondeterministic Choice --
--------------------------------------------------------------------------------

-- | A data type for representing nondeterminstic choice.
data NonDet a where
    MZero :: NonDet a
    MPlus :: NonDet Bool

instance Member NonDet effs => Alternative (Eff effs) where
    empty = mzero
    (<|>) = mplus

instance Member NonDet effs => MonadPlus (Eff effs) where
    mzero       = send MZero
    mplus m1 m2 = send MPlus >>= \x -> if x then m1 else m2