{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeOperators         #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.Coproduct.Strict
-- Copyright   :  (c) 2015 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- A strict coproduct of two monoids.
--
-----------------------------------------------------------------------------

module Data.Monoid.Coproduct.Strict
  (
    -- * Coproduct
    (:+:)
  , inL, inR
  , prependL, prependR
  , killL, killR
  , untangle

  -- ** Lenses
  , untangled
  , _L
  , _R

  ) where

import           Data.Monoid.Action
import           Data.Monoid.WithSemigroup
import           Data.Semigroup
import           Prelude

-- Internal strict version of Maybe
data Possible a = Only !a | Nought

instance Semigroup a => Semigroup (Possible a) where
  Only a
a <> :: Possible a -> Possible a -> Possible a
<> Only a
b = a -> Possible a
forall a. a -> Possible a
Only (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b)
  Possible a
Nought <> Possible a
b      = Possible a
b
  Possible a
a      <> Possible a
_      = Possible a
a
  {-# INLINE (<>) #-}

instance Semigroup a => Monoid (Possible a) where
  mempty :: Possible a
mempty = Possible a
forall a. Possible a
Nought
  {-# INLINE mempty #-}
  mappend :: Possible a -> Possible a -> Possible a
mappend = Possible a -> Possible a -> Possible a
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}

-- | @m :+: n@ is the coproduct of monoids @m@ and @n@. Concatentation
--   is equivilent to
--
-- @
-- (m1 :+: n1) <> (m2 :+: n2) = (m1 <> m2) :+: (n1 <> act m1 n2)@
-- @
--
--   but has a more efficient internal implimentation.
data m :+: n = C !(Possible n) !(Possible m) !(Possible n)
-- The left n already has the action m applied. The right n still needs
-- m applied, but it kept there incase more n comes to reduce the number
-- of actions that need to be applied.

instance (Action m n, Monoid m, Monoid' n, Show m, Show n) => Show (m :+: n) where
  showsPrec :: Int -> (m :+: n) -> ShowS
showsPrec Int
p m :+: n
c = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
    Int -> m -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 m
m ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" :+: " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> n -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 n
n
    where (m
m,n
n) = (m :+: n) -> (m, n)
forall m n.
(Action m n, Monoid m, Monoid' n) =>
(m :+: n) -> (m, n)
untangle m :+: n
c

instance (Action m n, Semigroup m, Semigroup n) => Semigroup (m :+: n) where
  C Possible n
n1 Possible m
m1 Possible n
o1 <> :: (m :+: n) -> (m :+: n) -> m :+: n
<> C Possible n
n2 Possible m
m2 Possible n
o2 = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (Possible n
n1 Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m1 (Possible n
o1 Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible n
n2)) (Possible m
m1 Possible m -> Possible m -> Possible m
forall a. Semigroup a => a -> a -> a
<> Possible m
m2) Possible n
o2
  {-# INLINE (<>) #-}

instance (Action m n, Semigroup m, Semigroup n) => Monoid (m :+: n) where
  mempty :: m :+: n
mempty  = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C Possible n
forall a. Possible a
Nought Possible m
forall a. Possible a
Nought Possible n
forall a. Possible a
Nought
  {-# INLINE mempty #-}
  mappend :: (m :+: n) -> (m :+: n) -> m :+: n
mappend = (m :+: n) -> (m :+: n) -> m :+: n
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}

-- | Coproducts act on other things by having each of the components
--   act individually.
instance (Action m n, Action m r, Action n r, Semigroup n) => Action (m :+: n) r where
  act :: (m :+: n) -> r -> r
act (C Possible n
n Possible m
m Possible n
o) = Possible n -> r -> r
forall m n. Action m n => Possible m -> n -> n
act'' Possible n
n' (r -> r) -> (r -> r) -> r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Possible m -> r -> r
forall m n. Action m n => Possible m -> n -> n
act'' Possible m
m
    where !n' :: Possible n
n' = Possible n
n Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m Possible n
o
  {-# INLINE act #-}

-- | Construct a coproduct with a left value.
inL :: m -> m :+: n
inL :: m -> m :+: n
inL m
m = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C Possible n
forall a. Possible a
Nought (m -> Possible m
forall a. a -> Possible a
Only m
m) Possible n
forall a. Possible a
Nought
{-# INLINE inL #-}

-- | Construct a coproduct with a right value.
inR :: n -> m :+: n
inR :: n -> m :+: n
inR n
r = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (n -> Possible n
forall a. a -> Possible a
Only n
r) Possible m
forall a. Possible a
Nought Possible n
forall a. Possible a
Nought
{-# INLINE inR #-}

-- | Prepend a value from the left.
prependL :: Semigroup m => m -> m :+: n -> m :+: n
prependL :: m -> (m :+: n) -> m :+: n
prependL m
m' (C Possible n
n Possible m
m Possible n
o) = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C Possible n
n (m -> Possible m
forall a. a -> Possible a
Only m
m' Possible m -> Possible m -> Possible m
forall a. Semigroup a => a -> a -> a
<> Possible m
m) Possible n
o
{-# INLINE prependL #-}

-- | Prepend a value from the right.
prependR :: Semigroup n => n -> m :+: n -> m :+: n
prependR :: n -> (m :+: n) -> m :+: n
prependR n
n' (C Possible n
n Possible m
m Possible n
o) = Possible n -> Possible m -> Possible n -> m :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (n -> Possible n
forall a. a -> Possible a
Only n
n' Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible n
n) Possible m
m Possible n
o
{-# INLINE prependR #-}

-- | Extract @m@ from a coproduct.
killR :: Monoid m => m :+: n -> m
killR :: (m :+: n) -> m
killR (C Possible n
_ Possible m
m Possible n
_) = Possible m -> m
forall a. Monoid a => Possible a -> a
get Possible m
m
{-# INLINE killR #-}

-- | Extract @n@ from a coproduct.
killL :: (Action m n, Monoid' n) => m :+: n -> n
killL :: (m :+: n) -> n
killL (C Possible n
n Possible m
m Possible n
o) = Possible n -> n
forall a. Monoid a => Possible a -> a
get (Possible n -> n) -> Possible n -> n
forall a b. (a -> b) -> a -> b
$ Possible n
n Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m Possible n
o
{-# INLINE killL #-}

untangle :: (Action m n, Monoid m, Monoid' n) => m :+: n -> (m,n)
untangle :: (m :+: n) -> (m, n)
untangle (C Possible n
n Possible m
m Possible n
o) = (Possible m -> m
forall a. Monoid a => Possible a -> a
get Possible m
m, Possible n -> n
forall a. Monoid a => Possible a -> a
get Possible n
n')
  where !n' :: Possible n
n' = Possible n
n Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m Possible n
o
{-# INLINE untangle #-}

-- Lenses --------------------------------------------------------------

type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

-- | Lens onto the both @m@ and @n@.
untangled :: (Action m n, Monoid m, Monoid' n) => Lens (m :+: n) (m' :+: n') (m,n) (m',n')
untangled :: Lens (m :+: n) (m' :+: n') (m, n) (m', n')
untangled (m, n) -> f (m', n')
f m :+: n
c = (m, n) -> f (m', n')
f ((m :+: n) -> (m, n)
forall m n.
(Action m n, Monoid m, Monoid' n) =>
(m :+: n) -> (m, n)
untangle m :+: n
c) f (m', n') -> ((m', n') -> m' :+: n') -> f (m' :+: n')
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(m'
m',n'
n') -> Possible n' -> Possible m' -> Possible n' -> m' :+: n'
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (n' -> Possible n'
forall a. a -> Possible a
Only n'
n') (m' -> Possible m'
forall a. a -> Possible a
Only m'
m') Possible n'
forall a. Possible a
Nought
{-# INLINE untangled #-}
-- this could be an iso if we depended on profunctors

-- | Lens onto the left value of a coproduct.
_L :: (Action m n, Monoid m, Semigroup n) => Lens (m :+: n) (m' :+: n) m m'
_L :: Lens (m :+: n) (m' :+: n) m m'
_L m -> f m'
f (C Possible n
n Possible m
m Possible n
o) = m -> f m'
f (Possible m -> m
forall a. Monoid a => Possible a -> a
get Possible m
m) f m' -> (m' -> m' :+: n) -> f (m' :+: n)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \m'
m' -> Possible n -> Possible m' -> Possible n -> m' :+: n
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (Possible n
n Possible n -> Possible n -> Possible n
forall a. Semigroup a => a -> a -> a
<> Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m Possible n
o) (m' -> Possible m'
forall a. a -> Possible a
Only m'
m') Possible n
forall a. Possible a
Nought
{-# INLINE _L #-}
-- this could be a prism if we depended on profunctors

-- | Lens onto the right value of a coproduct.
_R :: (Action m n, Monoid' n) => Lens (m :+: n) (m :+: n') n n'
_R :: Lens (m :+: n) (m :+: n') n n'
_R n -> f n'
f (C Possible n
n Possible m
m Possible n
o) = n -> f n'
f (Possible n -> n
forall a. Monoid a => Possible a -> a
get (Possible n -> n) -> Possible n -> n
forall a b. (a -> b) -> a -> b
$ Possible n
n Possible n -> Possible n -> Possible n
forall a. Monoid a => a -> a -> a
`mappend` Possible m -> Possible n -> Possible n
forall m n. Action m n => Possible m -> Possible n -> Possible n
act' Possible m
m Possible n
o) f n' -> (n' -> m :+: n') -> f (m :+: n')
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \n'
n' -> Possible n' -> Possible m -> Possible n' -> m :+: n'
forall m n. Possible n -> Possible m -> Possible n -> m :+: n
C (n' -> Possible n'
forall a. a -> Possible a
Only n'
n') Possible m
m Possible n'
forall a. Possible a
Nought
{-# INLINE _R #-}

-- Internal utilities --------------------------------------------------

get :: Monoid a => Possible a -> a
get :: Possible a -> a
get (Only a
a) = a
a
get Possible a
_        = a
forall a. Monoid a => a
mempty
{-# INLINE get #-}

(<&>) :: Functor f => f a -> (a -> b) -> f b
<&> :: f a -> (a -> b) -> f b
(<&>) = ((a -> b) -> f a -> f b) -> f a -> (a -> b) -> f b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
{-# INLINE (<&>) #-}

-- Act on a possible with a possible
act' :: Action m n => Possible m -> Possible n -> Possible n
act' :: Possible m -> Possible n -> Possible n
act' (Only m
m) (Only n
n) = n -> Possible n
forall a. a -> Possible a
Only (m -> n -> n
forall m s. Action m s => m -> s -> s
act m
m n
n)
act' Possible m
_        Possible n
n        = Possible n
n
{-# INLINE act' #-}

-- Act with a possible
act'' :: Action m n => Possible m -> n -> n
act'' :: Possible m -> n -> n
act'' (Only m
m) = m -> n -> n
forall m s. Action m s => m -> s -> s
act m
m
act'' Possible m
_        = n -> n
forall a. a -> a
id
{-# INLINE act'' #-}