{-# LANGUAGE OverlappingInstances, TypeOperators, FlexibleInstances #-}
-- | This module contains the basic data types underlying the
-- 'IOSpec' library. Most of the types and classes in this module
-- are described in
-- <https://webspace.science.uu.nl/~swier004//publications/2008-jfp.pdf>
module Test.IOSpec.Types
  (
  -- * The 'IOSpec' type.
    IOSpec(..)
  , foldIOSpec
  -- * Coproducts of functors
  , (:+:)(..)
  -- * Injections from one functor to another
  , (:<:)
  , inject
  ) where

import Control.Monad (ap)

-- | A value of type 'IOSpec' @f@ @a@ is either a pure value of type @a@
-- or some effect, determined by @f@. Crucially, 'IOSpec' @f@ is a
-- monad, provided @f@ is a functor.
data IOSpec f a =
    Pure a
  | Impure (f (IOSpec f a))

instance (Functor f) => Functor (IOSpec f) where
  fmap :: forall a b. (a -> b) -> IOSpec f a -> IOSpec f b
fmap a -> b
f (Pure a
x)   = forall (f :: * -> *) a. a -> IOSpec f a
Pure (a -> b
f a
x)
  fmap a -> b
f (Impure f (IOSpec f a)
t) = forall (f :: * -> *) a. f (IOSpec f a) -> IOSpec f a
Impure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (IOSpec f a)
t)

instance (Functor f) => Applicative (IOSpec f) where
  pure :: forall a. a -> IOSpec f a
pure             = forall (f :: * -> *) a. a -> IOSpec f a
Pure
  <*> :: forall a b. IOSpec f (a -> b) -> IOSpec f a -> IOSpec f b
(<*>)            = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Functor f) => Monad (IOSpec f) where
  return :: forall a. a -> IOSpec f a
return           = forall (f :: * -> *) a. a -> IOSpec f a
Pure
  (Pure a
x) >>= :: forall a b. IOSpec f a -> (a -> IOSpec f b) -> IOSpec f b
>>= a -> IOSpec f b
f   = a -> IOSpec f b
f a
x
  (Impure f (IOSpec f a)
t) >>= a -> IOSpec f b
f = forall (f :: * -> *) a. f (IOSpec f a) -> IOSpec f a
Impure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IOSpec f b
f) f (IOSpec f a)
t)

-- | The fold over 'IOSpec' values.
foldIOSpec :: Functor f => (a -> b) -> (f b -> b) -> IOSpec f a -> b
foldIOSpec :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> (f b -> b) -> IOSpec f a -> b
foldIOSpec a -> b
pure f b -> b
_      (Pure a
x)    = a -> b
pure a
x
foldIOSpec a -> b
pure f b -> b
impure (Impure f (IOSpec f a)
t)  = f b -> b
impure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> (f b -> b) -> IOSpec f a -> b
foldIOSpec a -> b
pure f b -> b
impure) f (IOSpec f a)
t)

-- | The coproduct of functors
data (f :+: g) x = Inl (f x) | Inr (g x)

infixr 5 :+:

instance (Functor f, Functor g) => Functor (f :+: g) where
  fmap :: forall a b. (a -> b) -> (:+:) f g a -> (:+:) f g b
fmap a -> b
f (Inl f a
x) = forall (f :: * -> *) (g :: * -> *) x. f x -> (:+:) f g x
Inl (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
x)
  fmap a -> b
f (Inr g a
y) = forall (f :: * -> *) (g :: * -> *) x. g x -> (:+:) f g x
Inr (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f g a
y)

-- | The (:<:) class

class (Functor sub, Functor sup) => sub :<: sup where
  inj :: sub a -> sup a

instance Functor f => (:<:) f f where
  inj :: forall a. f a -> f a
inj = forall a. a -> a
id

instance (Functor f, Functor g) => (:<:) f (f :+: g) where
  inj :: forall a. f a -> (:+:) f g a
inj = forall (f :: * -> *) (g :: * -> *) x. f x -> (:+:) f g x
Inl

instance ((:<:) f g, Functor f, Functor g, Functor h)
  => (:<:) f (h :+: g) where
    inj :: forall a. f a -> (:+:) h g a
inj = forall (f :: * -> *) (g :: * -> *) x. g x -> (:+:) f g x
Inr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj

inject :: (g :<: f) => g (IOSpec f a) -> IOSpec f a
inject :: forall (g :: * -> *) (f :: * -> *) a.
(g :<: f) =>
g (IOSpec f a) -> IOSpec f a
inject = forall (f :: * -> *) a. f (IOSpec f a) -> IOSpec f a
Impure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj