{-# LANGUAGE CPP                        #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE UndecidableInstances       #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances       #-}
#endif

{-# OPTIONS_GHC -fno-warn-orphans #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Monoid.MList
-- Copyright   :  (c) 2011 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Heterogeneous lists of monoids.
--
-----------------------------------------------------------------------------
module Data.Monoid.MList
       ( -- * Heterogeneous monoidal lists

         -- $mlist

         (:::), (*:)

       , MList(..)

         -- * Accessing embedded values
       , (:>:)(..)

         -- * Monoid actions of heterogeneous lists

         -- $mlist-actions

       , SM(..)
       ) where

import           Control.Arrow
import           Data.Monoid.Action

-- $mlist
--
-- The idea of /heterogeneous lists/ has been around for a long time.
-- Here, we adopt heterogeneous lists where the element types are all
-- monoids: this allows us to leave out identity values, so that a
-- heterogeneous list containing only a single non-identity value can
-- be created without incurring constraints due to all the other
-- types, by leaving all the other values out.

infixr 5 :::
infixr 5 *:

type a ::: l = (Maybe a, l)

(*:) :: a -> l -> a ::: l
a
a *: :: a -> l -> a ::: l
*: l
l = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, l
l)

-- MList -----------------------------------

-- | Type class for heterogeneous monoidal lists, with a single method
--   allowing construction of an empty list.
class MList l where
  -- | The /empty/ heterogeneous list of type @l@. Of course, @empty
  -- == 'mempty'@, but unlike 'mempty', @empty@ does not require
  -- 'Monoid' constraints on all the elements of @l@.
  empty   :: l

instance MList () where
  empty :: ()
empty     = ()

instance MList l => MList (a ::: l) where
  empty :: a ::: l
empty   = (Maybe a
forall a. Maybe a
Nothing, l
forall l. MList l => l
empty)

-- Embedding -------------------------------------------

-- | The relation @l :>: a@ holds when @a@ is the type of an element
--   in @l@.  For example,  @(Char ::: Int ::: Bool ::: Nil) :>: Int@.
class l :>: a where
  -- | Inject a value into an otherwise empty heterogeneous list.
  inj  :: a -> l

  -- | Get the value of type @a@ from a heterogeneous list, if there
  --   is one.
  get  :: l -> Maybe a

  -- | Alter the value of type @a@ by applying the given function to it.
  alt  :: (Maybe a -> Maybe a) -> l -> l

#if __GLASGOW_HASKELL__ >= 710
instance {-# OVERLAPPING #-} MList t => (:>:) (a ::: t) a where
#else
instance MList t => (:>:) (a ::: t) a where
#endif
  inj :: a -> a ::: t
inj a
a = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, t
forall l. MList l => l
empty)
  get :: (a ::: t) -> Maybe a
get   = (a ::: t) -> Maybe a
forall a b. (a, b) -> a
fst
  alt :: (Maybe a -> Maybe a) -> (a ::: t) -> a ::: t
alt   = (Maybe a -> Maybe a) -> (a ::: t) -> a ::: t
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

instance (t :>: a) => (:>:) (b ::: t) a where
  inj :: a -> b ::: t
inj a
a = (Maybe b
forall a. Maybe a
Nothing, a -> t
forall l a. (l :>: a) => a -> l
inj a
a)
  get :: (b ::: t) -> Maybe a
get   = t -> Maybe a
forall l a. (l :>: a) => l -> Maybe a
get (t -> Maybe a) -> ((b ::: t) -> t) -> (b ::: t) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b ::: t) -> t
forall a b. (a, b) -> b
snd
  alt :: (Maybe a -> Maybe a) -> (b ::: t) -> b ::: t
alt   = (t -> t) -> (b ::: t) -> b ::: t
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((t -> t) -> (b ::: t) -> b ::: t)
-> ((Maybe a -> Maybe a) -> t -> t)
-> (Maybe a -> Maybe a)
-> (b ::: t)
-> b ::: t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Maybe a) -> t -> t
forall l a. (l :>: a) => (Maybe a -> Maybe a) -> l -> l
alt

-- Monoid actions -----------------------------------------

-- $mlist-actions
-- Monoidal heterogeneous lists may act on one another as you would
-- expect, with each element in the first list acting on each in the
-- second.  Unfortunately, coding this up in type class instances is a
-- bit fiddly.

-- | @SM@, an abbreviation for \"single monoid\" (as opposed to a
--   heterogeneous list of monoids), is only used internally to help
--   guide instance selection when defining the action of
--   heterogeneous monoidal lists on each other.
newtype SM m = SM m
               deriving Int -> SM m -> ShowS
[SM m] -> ShowS
SM m -> String
(Int -> SM m -> ShowS)
-> (SM m -> String) -> ([SM m] -> ShowS) -> Show (SM m)
forall m. Show m => Int -> SM m -> ShowS
forall m. Show m => [SM m] -> ShowS
forall m. Show m => SM m -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SM m] -> ShowS
$cshowList :: forall m. Show m => [SM m] -> ShowS
show :: SM m -> String
$cshow :: forall m. Show m => SM m -> String
showsPrec :: Int -> SM m -> ShowS
$cshowsPrec :: forall m. Show m => Int -> SM m -> ShowS
Show

instance (Action (SM a) l2, Action l1 l2) => Action (a, l1) l2 where
  act :: (a, l1) -> l2 -> l2
act (a
a,l1
l) = SM a -> l2 -> l2
forall m s. Action m s => m -> s -> s
act (a -> SM a
forall m. m -> SM m
SM a
a) (l2 -> l2) -> (l2 -> l2) -> l2 -> l2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l1 -> l2 -> l2
forall m s. Action m s => m -> s -> s
act l1
l

instance Action (SM a) () where
  act :: SM a -> () -> ()
act SM a
_ ()
_ = ()

instance (Action a a', Action (SM a) l) => Action (SM a) (Maybe a', l) where
  act :: SM a -> (Maybe a', l) -> (Maybe a', l)
act (SM a
a) (Maybe a'
Nothing,   l
l) = (Maybe a'
forall a. Maybe a
Nothing, SM a -> l -> l
forall m s. Action m s => m -> s -> s
act (a -> SM a
forall m. m -> SM m
SM a
a) l
l)
  act (SM a
a) (Just a'
a', l
l) = (a' -> Maybe a'
forall a. a -> Maybe a
Just (a -> a' -> a'
forall m s. Action m s => m -> s -> s
act a
a a'
a'), SM a -> l -> l
forall m s. Action m s => m -> s -> s
act (a -> SM a
forall m. m -> SM m
SM a
a) l
l)