Simple.hs

{-# LANGUAGE ExplicitNamespaces, NoImplicitPrelude, RankNTypes, TupleSections,
             TypeOperators #-}
module Control.Arrow.Elision.Simple
       ( -- * Types
         Elision
       , Elision'

         -- * Constructors
       , basic
       , elide
       , elideLeft
       , elideRight
       , terminal

         -- * Manipulation
       , apply
       , complete
       , complete'
       , unelide
       , unelide'

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

       -- * Arrow combinator re-exports
       , Arrow
       , ArrowApply
       , ArrowChoice
       , (***)
       , (&&&)
       , (|||)
       , (+++)
       , (<<<)
       , (<<^)
       , (^>>)
       , (>>^)
       , (^<<)
       , arr
       ) where


import Control.Applicative (Applicative (..))
import Control.Arrow       (Arrow (..), ArrowApply (..), ArrowChoice (..),
                            (<<^), (>>^), (^<<), (^>>))
import Control.Category    (Category (..), (<<<), (>>>))
import Control.Monad       (Functor (..), Monad (..), (<=<), (=<<))
import Data.Either         (Either (..))
import Data.Function       (const, flip, ($))
import Data.Profunctor     (Profunctor (..))

infixr 2 //
infixr 4 />>, <</

--------------------------------------------------------------------------------
-- | 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)))

  el0 <*> el1 =
    Elision $ \cont arg ->
        complete cont arg el0 <*> complete cont arg el1

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

instance Profunctor (Elision f) where
  dimap l r el =
    Elision $ \cont ->
      let fn = unelide el cont
       in dimap l (fmap r) fn

instance Category (Elision f) where
  id =
    Elision (const pure)

  el1 . el0 =
    Elision (\cont -> unelide el1 cont <=< unelide el0 cont)

instance Arrow (Elision f) where
  arr fn =
    Elision (const (pure . fn))

  first el =
    Elision (\cont ~(x,y) -> fmap (,y) (unelide el cont x))

instance ArrowChoice (Elision f) where
  left el = Elision $ \cont ->
    fmap Left . unelide el cont ||| pure . Right

instance ArrowApply (Elision f) where
  app = Elision (\cont ~(el, arg) -> complete' cont (el `apply` 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 el) =
  el

--------------------------------------------------------------------------------
-- | 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' el fn =
  unelide el 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 el) =
  el 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 ()

--------------------------------------------------------------------------------
-- | Apply an argument to an arrow and close off the input.
apply :: Arrow a => a b c -> b -> a () c
apply arrow arg =
  arrow <<^ const arg

--------------------------------------------------------------------------------
-- | The simplest elision, effectively the identity function.
basic :: Elision' f a
basic =
  Elision (\f x -> f 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 =
  dimap f g basic

--------------------------------------------------------------------------------
-- | Create an elision chained to the end of the provided function.
elideLeft :: (a -> f b) -> Elision f a b
elideLeft =
  flip elide id

--------------------------------------------------------------------------------
-- | Create an elision chained to the beginning of the provided function.
elideRight :: (a -> b) -> Elision f (f a) b
elideRight =
  elide id

--------------------------------------------------------------------------------
-- | Create an elision with the input fully applied.
terminal :: f a -> Elision f () a
terminal x =
  elideLeft (const 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 =
  f ||| g <<^ runSum

--------------------------------------------------------------------------------
-- | Like 'left', but over the first type argument.
left' :: Elision f a b -> Elision (f // g) a b
left' el =
  Elision (\cont -> unelide el (cont . 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.
--
-- This is analogous to a lifted '(>>>)'.
(/>>) :: Elision f a b -> Elision g b c -> Elision (f // g) a c
a />> b =
  left' a >>> right' b

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