Elision.hs

{-# LANGUAGE ExplicitNamespaces, NoImplicitPrelude, RankNTypes, TupleSections,
             TypeOperators #-}
{- |
Module      : Control.Arrow.Elision
Description : Two functions with a missing "link" to be completed at a later time.
Copyright   : (c) 2016 Alex Crough
License     : BSD2
Maintainer  : alex@crough.io
Stability   : Experimental
Portability : RankNTypes, TupleSection, TypeOperators
-}
module Control.Arrow.Elision
       ( -- * Types
         Elision
       , Elision'

         -- * Elision manipulation functions
       , complete
       , complete'
       , elide
       , initial
       , simple
       , unelide
       , unelide'

         -- * Combining Interpreters
       , Sum
       , type (//)
       , (//)
       , left'
       , right'
       , (/>)
       , (</)

         -- * Reexports
       , module Control.Arrow
       , module Data.Profunctor
       )
       where

import Control.Applicative (Applicative (..))
import Control.Arrow       (Arrow (..), ArrowApply (..), ArrowChoice (..),
                            ArrowMonad, second, (&&&), (***), (+++), (<<<),
                            (<<^), (>>>), (>>^), (^<<), (^>>), (|||))
import Control.Category    (Category (..))
import Control.Monad       (Functor (..), Monad (..), (=<<))
import Data.Either         (Either (..), either)
import Data.Function       (const, ($))
import Data.Profunctor     (Profunctor (..))

--------------------------------------------------------------------------------
-- | A lens-esque type that can be used to "skip" part of a function.
--
-- An 'Elision' can be used in the common interpreter pattern, in which case
-- @f@ represents the DSL type, @a@ represents the input of a function and @b@
-- represents the output.
--
-- Use 'complete' or 'unelide' to deconstruct the type.
newtype Elision f a b =
  Elision (forall m. Monad m => (forall t. f t -> m t) -> a -> m b)

instance Functor (Elision f a) where
  fmap = rmap

instance Applicative (Elision f a) where
  pure x    = Elision (const (const (pure x)))
  e0 <*> e1 = Elision $ \e' arg -> unelide e0 e' arg <*> unelide e1 e' arg

instance Monad (Elision f a) where
  e >>= fn = Elision $ \e' arg -> complete e' arg . fn =<< complete e' arg e

instance Profunctor (Elision f) where
  dimap l r e = Elision $ \e' -> dimap l (fmap r) (unelide e e')

instance Category (Elision f) where
  id      = Elision $ \_  arg -> pure arg
  e1 . e0 = Elision $ \e' arg -> unelide e1 e' =<< unelide e0 e' arg

instance Arrow (Elision f) where
  arr   fn = Elision $ \_ -> pure . fn
  first e  = Elision $ \e' (x,y) -> fmap (,y) (unelide e e' x)

instance ArrowChoice (Elision f) where
  left e = Elision $ \e' arg ->
    case arg of
      Left l  -> fmap Left (unelide e e' l)
      Right r -> pure (Right r)

instance ArrowApply (Elision f) where
  app = Elision $ \e' (arr', arg) -> complete' e' (arr' <<^ const arg)

--------------------------------------------------------------------------------
-- | The type of the simplist elision, where @unelide eli f = f@
type Elision' f a = Elision f (f a) a

--------------------------------------------------------------------------------
-- | Deconstruct an Elision, returning its inner type.
unelide :: Monad m => Elision f a b -> (forall c. f c -> m c) -> a -> m b
unelide (Elision e) = e

--------------------------------------------------------------------------------
-- | Like 'unelide', but applies the unit type to the function immediately.
unelide' :: Monad m => Elision f () b -> (forall c. f c -> m c) -> m b
unelide' e fn = unelide e fn ()

--------------------------------------------------------------------------------
-- | Construct an interpreter for an elision out of a function an initial
-- argument.
complete :: Monad m => (forall c. f c -> m c) -> a -> Elision f a b -> m b
complete fn arg (Elision e) = e fn arg

--------------------------------------------------------------------------------
-- | Like 'complete', but the unit type never has to be provided.
complete' :: Monad m => (forall c. f c -> m c) -> Elision f () b -> m b
complete' fn = complete fn ()

--------------------------------------------------------------------------------
-- | The simplest elision, effectively the identity function.
simple :: Elision' f a
simple = Elision (\f x -> f x)

--------------------------------------------------------------------------------
-- | Apply a value to an elision immediately.
initial :: f a -> Elision f () a
initial x = simple <<^ const x

--------------------------------------------------------------------------------
-- | Create an elision out of two functions to be completed at a later date.
elide :: (a -> f c) -> (c -> b) -> Elision f a b
elide f g = Elision $ \e' x -> dimap f (fmap g) e' x

--------------------------------------------------------------------------------
-- | Either @f a@ or @g a@.
newtype Sum f g a =
  Sum { runSum :: Either (f a) (g a) }

--------------------------------------------------------------------------------
-- | A type synonym for 'Sum' to create harmony with the '//' function.
type a // b = Sum a b

--------------------------------------------------------------------------------
-- | Create a function that can complete an elision of a sum out of two
-- functions that can complete each individual parts.
(//) :: (forall b. f b -> m b) -> (forall b. g b -> m b) -> Sum f g a -> m a
f // g = either f g . runSum

--------------------------------------------------------------------------------
-- | Like 'left', but over the first type argument.
left' :: Elision f a b -> Elision (f // g) a b
left' e = Elision $ \e' -> unelide e (e' . Sum . Left)

--------------------------------------------------------------------------------
-- | Like 'right', but over the first type argument.
right' :: Elision g a b -> Elision (f // g) a b
right' e = Elision $ \e' -> unelide e (e' . Sum . Right)

--------------------------------------------------------------------------------
-- | Send the output of the left to the input of right, and add their @f@
-- types together.
(/>) :: Elision f a b -> Elision g b c -> Elision (f // g) a c
a /> b = right' b . left' a

--------------------------------------------------------------------------------
-- | Send the output of the right to the input of the left, and add their @f@
-- types together.
(</) :: Elision f b c -> Elision g a b -> Elision (f // g) a c
b </ a = left' b . right' a