flexiwrap-0.1.0: Data/Flex/Wrap.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-- .$Header: c:/Source/Haskell/Wrapper/Data/Flex/RCS/Wrap.hs,v 1.18 2011/09/20 23:46:14 dosuser Exp dosuser $

-- | The flexible value wrapper @'FlexiWrap'@ and associated types and classes

module Data.Flex.Wrap (
    -- * @'FlexiWrap'@
    -- | and related instance machinery

    -- ** @'FlexiWrap'@
    -- | with a type synonym and alternative constructors
    FlexiWrap(..),
    FW,
    flexiWrap,
    flexiWrapP,
    -- ** Instance selectors
    FWDefaultEq(..),
    FWTransparentEq(..),
    FWDefaultOrd(..),
    FWTransparentOrd(..),
    FWReverseOrd(..),
    FWDefaultShowRead(..),
    FWLiteralShowRead(..),
    FWTransparentShowRead(..),
    FWDefaultArbitrary(..),
    FWTransparentArbitrary(..),
    FWDefaultMonoid(..),
    FWTransparentMonoid(..),
    FWDualMonoid(..),
    FWEndoMonoid(..),
    FWAllMonoid(..),
    FWAnyMonoid(..),
    FWSumMonoid(..),
    FWProductMonoid(..),
    FWFirstMonoid(..),
    FWLastMonoid(..),
    -- ** Machinery for @'Eq'@ instances
    FWEq,
    FWEquals(..),
    FWNotEquals(..),
    -- ** Machinery for @'Ord'@ instances
    FWOrd,
    FWCompare(..),
    -- ** Machinery for @'Show'@ and @'Read'@ instances
    FWShowRead,
    FWShow(..),
    FWRead(..),
    -- ** Machinery for @'Arbitrary'@ instances
    FWArbitraryC,
    FWArbitrary(..),
    FWCoarbitrary(..),
    -- ** Machinery for @'Monoid'@ instances
    FWMonoid,
    FWMempty(..),
    FWMappend(..),
    -- ** Utility functions
    inFlexiWrap,
    inFlexiWrap2,
    -- * Experimental features
    FWNormAppend,
    FWrap(..),
    FWIsWrapped,
    FWAlreadyWrapped(..),
    FWNewWrapper(..)
) where

import Control.Applicative (Applicative(..))
    -- , (<$>), liftA2, Alternative(..))

import Data.Foldable as F (Foldable(..))
import Data.Monoid (Monoid(..))
import qualified Data.Traversable as T (Traversable(..))

import Test.QuickCheck (Arbitrary(..), Gen)

import Data.Type.Apply (Apply(..))
import Data.Type.Eq (TypeCast)
import Data.Type.Proxy (Proxy(..))
import Data.Type.TList ((:*:), TNil)

import Data.Flex.Arbitrary (WrapCoarbitrary(..))
import Data.Flex.Utils (inCompose, inCompose2, on)

-- begin FlexiWrap

-- | The flexible value wrapper
newtype FlexiWrap s a = FlexiWrap {unFlexiWrap :: a}

-- | A handy abbreviated type synonym
type FW = FlexiWrap

-- | An alternative constructor
flexiWrap :: s -> a -> FW s a
flexiWrap _ = FlexiWrap

-- | An alternative constructor using a proxy
flexiWrapP :: Proxy s -> a -> FW s a
flexiWrapP _ = FlexiWrap

-- | The implementation of fmap for @'Functor' ('FW' s)@
inFlexiWrap :: (a -> b) -> (FW s a -> FW s b)
inFlexiWrap = inCompose unFlexiWrap FlexiWrap

-- | An extension of fmap to two-argument functions
inFlexiWrap2 :: (a -> b -> c) -> (FW s a -> FW s b -> FW s c)
-- inFlexiWrap2 = inCompose unFlexiWrap $ inCompose unFlexiWrap FlexiWrap
inFlexiWrap2 = inCompose2 unFlexiWrap FlexiWrap

-- TODO: Use flexible instance machinery?

instance Functor (FW t) where
    fmap = inFlexiWrap

instance Applicative (FW t) where
    pure = FlexiWrap
    (<*>) = inFlexiWrap . unFlexiWrap

instance F.Foldable (FW t) where
    foldr f z (FlexiWrap a) = f a z

instance T.Traversable (FW t) where
    traverse = (fmap FlexiWrap .) . (. unFlexiWrap)
    sequenceA = fmap FlexiWrap . unFlexiWrap

instance Monad (FW t) where
    return = FlexiWrap
    (>>=) = flip (. unFlexiWrap)

-- | Utility class to append two type-level lists
--
-- append \<s> and \<t> to produce \<u>.
-- \<s> may or may not be terminated by @'TNil'@;
-- if so, it does not appear in the result
class FWNormAppend s t u | s t -> u

instance FWNormAppend TNil t t

instance FWNormAppend s t u => FWNormAppend (x :*: s) t (x :*: u)

instance TypeCast u (x :*: t) => FWNormAppend x t u

-- | Utility class to create or tag-extend a wrapper

-- class FWrap w a b where
class FWrap w a b | w a -> b where
    fWrap :: w -> a -> b

-- | Analysis class to determine whether an argument is already wrapped,
-- used for @'FWrap'@
class FWIsWrapped a r | a -> r

-- | Result type for @'FWIsWrapped'@
data FWAlreadyWrapped = FWAlreadyWrapped
-- | Result type for @'FWIsWrapped'@
data FWNewWrapper = FWNewWrapper

-- | Function identifier type for @'Apply'@
data FWFWrap s a = FWFWrap

instance FWIsWrapped (FW s a) FWAlreadyWrapped
instance TypeCast r FWNewWrapper => FWIsWrapped a r

-- | * Implementation instance for @'FWrap'@
instance Apply (FWFWrap u a) FWNewWrapper (a -> FW u a) where
    apply _ _ = FlexiWrap
-- | * Implementation instance for @'FWrap'@
instance Apply (FWFWrap u (FW s a)) FWAlreadyWrapped (FW s a -> FW u a) where
    apply _ _ = FlexiWrap . unFlexiWrap

-- | Function identifier type for @'Apply'@
data FWTag

-- | * Analysis instance for @'FWTag'@
instance Apply FWTag (FW t a) t
-- | * Analysis instance for @'FWTag'@
instance TypeCast r TNil => Apply FWTag a r

-- | * Coordinating instance definition for @'FWrap'@
instance forall a b s t u w. (
        Apply FWTag a t,
        FWNormAppend s t u,
        FWIsWrapped a w,
        Apply (FWFWrap u a) w (a -> FW u b)
    ) =>
    FWrap s a (FW u b)
  where
    fWrap _ = apply (undefined :: FWFWrap u a) (undefined :: w)

{-
instance FWNormAppend s t u => FWrap s (FW t a) (FW u a) where
    fWrap _ (FlexiWrap a) = FlexiWrap a

instance FWNormAppend s TNil u => FWrap s a (FW u a) where
    fWrap _ = FlexiWrap
-}

{-
instance FWrap TNil (FW s a) (FW s a) where
    fWrap _ = id

instance FWrap s (FW t a) (FW u a) =>
        FWrap (w :*: s) (FW t a) (FW (w :*: u) a) where
    fWrap _ (FlexiWrap a) = FlexiWrap a

instance TypeCast t (w :*: s) => FWrap w (FW s a) (FW t a) where
    fWrap _ (FlexiWrap a) = FlexiWrap a

{-
instance FWrap w (FW s a) (FW (w :*: s) a) where
    fWrap _ (FlexiWrap a) = FlexiWrap a
-}

{-
instance TypeCast r (FW TNil a) => FWrap TNil a r where
    fWrap _ = FlexiWrap
-}

instance FWrap TNil a (FW TNil a) where
    fWrap _ = FlexiWrap

instance FWrap s a (FW t a) => FWrap (x :*: s) a (FW (x :*: t) a) where
    fWrap _ = FlexiWrap

instance FWrap w a (FW (w :*: TNil) a) where
    fWrap _ = FlexiWrap
-}

-- TODO: FWDefaultAll (except Num) selector

-- Eq

-- | Analysis class for @'Eq'@ instance selection.
-- You need a specific instance of this for any instance selectors
-- you may define.
class FWEq a r | a -> r

-- | Instance selector type for the default
-- (transparent) implementation of @'Eq'@
data FWDefaultEq = FWDefaultEq

-- | Instance selector type for the (default)
-- transparent implementation of @'Eq'@
data FWTransparentEq = FWTransparentEq

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWEquals t a = FWEquals

-- | Function identifier type for @'Apply'@
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWNotEquals t a = FWNotEquals

-- | * Default instance
instance TypeCast r FWTransparentEq => FWEq (FW t a) r

-- | * Propagated instance
instance FWEq (FW s a) r => FWEq (FW (x :*: s) a) r

-- | * Specific @'FWDefaultEq'@ instance
instance FWShowRead (FW (FWDefaultEq :*: s) a) FWTransparentEq

-- | * Specific @'FWTransparentEq'@ instance
instance FWShowRead (FW (FWTransparentEq :*: s) a) FWTransparentEq

-- | * Implementation instance for @'Eq'@ instance selection
instance Eq a => Apply (FWEquals t a) FWTransparentEq
    (FW t a -> FW t a -> Bool)
  where
    apply _ _ = (==) `on` unFlexiWrap

-- | * Implementation instance for @'Eq'@ instance selection
instance Eq a => Apply (FWNotEquals t a) FWTransparentEq
    (FW t a -> FW t a -> Bool)
  where
    apply _ _ = (/=) `on` unFlexiWrap

-- | * Coordinating instance for @'Eq'@
instance forall t a r. (Apply (FWEquals t a) r (FW t a -> FW t a -> Bool),
            Apply (FWNotEquals t a) r (FW t a -> FW t a -> Bool),
            FWEq (FW t a) r
        ) =>
        Eq (FW t a) where
    (==) = apply (undefined :: FWEquals t a) (undefined :: r)
    (/=) = apply (undefined :: FWNotEquals t a) (undefined :: r)

-- Ord

-- | Analysis class for @'Ord'@ instance selection
-- You need a specific instance of this for any instance selectors
-- you may define.
class FWOrd a r | a -> r

-- | Instance selector type for the default (transparent) @'Ord'@ instance
data FWDefaultOrd = FWDefaultOrd
-- | Instance selector type for the (default) transparent @'Ord'@ instance
data FWTransparentOrd = FWTransparentOrd
-- | Instance selector type for a reversed @'Ord'@ instance
data FWReverseOrd = FWReverseOrd

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWCompare t a = FWCompare

-- | * Default instance
instance TypeCast r FWTransparentOrd => FWOrd (FW t a) r

-- | * Propagated instance
instance FWOrd (FW s a) r => FWOrd (FW (x :*: s) a) r

-- | * Specific @'FWDefaultOrd'@ instance
instance FWOrd (FW (FWDefaultOrd :*: s) a) FWTransparentOrd

-- | * Specific @'FWTransparentOrd'@ instance
instance FWOrd (FW (FWTransparentOrd :*: s) a) FWTransparentOrd

-- | * Specific @'FWReverseOrd'@ instance
instance FWOrd (FW (FWReverseOrd :*: s) a) FWReverseOrd

-- | ** Implementation instance for @'Ord'@ instance selection
instance Ord a => Apply (Proxy (FWCompare t a)) (Proxy FWTransparentOrd)
    (FW t a -> FW t a -> Ordering)
  where
    apply _ _ = compare `on` unFlexiWrap

-- | ** Implementation instance for @'Ord'@ instance selection
instance Ord a => Apply (Proxy (FWCompare t a)) (Proxy FWReverseOrd)
    (FW t a -> FW t a -> Ordering)
  where
    apply _ _ = flip compare `on` unFlexiWrap

-- | * Coordinating instance of @'Ord'@
instance forall t a r. (
            Apply (Proxy (FWCompare t a)) (Proxy r)
                (FW t a -> FW t a -> Ordering),
            FWOrd (FW t a) r,
            Eq (FW t a)
        ) =>
        Ord (FW t a) where
    compare = apply (Proxy :: Proxy (FWCompare t a)) (Proxy :: Proxy r)

-- Show/Read

app_prec :: Int
app_prec = 10

-- | Analysis class for @'Show/Read'@ instance selection
-- You need a specific instance of this for any instance selectors
-- you may define.
class FWShowRead a r | a -> r

-- | Instance selector type for the default (literal) @'Show'/'Read'@
-- instances
data FWDefaultShowRead = FWDefaultShowRead deriving (Show, Read)

-- | Instance selector type for the (default) literal @'Show'/'Read'@
-- instances
data FWLiteralShowRead = FWLiteralShowRead deriving (Show, Read)

-- | Instance selector type for transparent @'Show'/'Read'@ instances
data FWTransparentShowRead = FWTransparentShowRead deriving (Show, Read)

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWShow t a = FWShow

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWRead t a = FWRead

-- | * Default instance
instance TypeCast r FWLiteralShowRead => FWShowRead (FW t a) r

-- | * Propagated instance
instance FWShowRead (FW s a) r => FWShowRead (FW (x :*: s) a) r

-- | * Specific @'FWDefaultShowRead'@ instance
instance FWShowRead (FW (FWDefaultShowRead :*: s) a) FWLiteralShowRead

-- | * Specific @'FWLiteralShowRead'@ instance
instance FWShowRead (FW (FWLiteralShowRead :*: s) a) FWLiteralShowRead

-- | * Specific @'FWTransparentShowRead'@ instance
instance FWShowRead (FW (FWTransparentShowRead :*: s) a) FWTransparentShowRead

-- | ** Implementation instance for @'Show'@ instance selection
instance Show a =>
    Apply (Proxy (FWShow t a)) (Proxy FWLiteralShowRead)
        (Int -> FW t a -> ShowS)
  where
    apply _ _ d (FlexiWrap w) = showParen (d > app_prec) $
        showString "FlexiWrap " . showsPrec (app_prec+1) w

-- | ** Implementation instance for @'Read'@ instance selection
instance Read a =>
    Apply (Proxy (FWRead t a)) (Proxy FWLiteralShowRead)
        (Int -> ReadS (FW t a))
  where
    apply _ _ d r = readParen
        (d > app_prec)
        (\v -> [(FlexiWrap m, t) |
            ("FlexiWrap", s) <- lex v,
            (m, t) <- readsPrec (app_prec+1) s
        ])
        r

-- | ** Implementation instance for @'Show'@ instance selection
instance Show a =>
    Apply (Proxy (FWShow t a)) (Proxy FWTransparentShowRead)
        (Int -> FW t a -> ShowS)
  where
    apply _ _ d (FlexiWrap w) = showParen (d > app_prec) $
        showsPrec (app_prec+1) w

-- | ** Implementation instance for @'Read'@ instance selection
instance Read a =>
    Apply (Proxy (FWRead t a)) (Proxy FWTransparentShowRead)
        (Int -> ReadS (FW t a))
  where
    apply _ _ d r = readParen
        (d > app_prec)
        (\s -> [(FlexiWrap m, t) |
            (m, t) <- readsPrec (app_prec+1) s
        ])
        r

-- | * Coordinating instance of @'Show'@
instance forall t a r. (
            Apply (Proxy (FWShow t a)) (Proxy r)
                (Int -> FW t a -> ShowS),
            FWShowRead (FW t a) r
        ) =>
        Show (FW t a) where
    showsPrec = apply (Proxy :: Proxy (FWShow t a)) (Proxy :: Proxy r)

-- | * Coordinating instance of @'Read'@
instance forall t a r. (
            Apply (Proxy (FWRead t a)) (Proxy r)
                (Int -> ReadS (FW t a)),
            FWShowRead (FW t a) r
        ) =>
        Read (FW t a) where
    readsPrec = apply (Proxy :: Proxy (FWRead t a)) (Proxy :: Proxy r)

-- Arbitrary

-- | Analysis class for @'Arbitrary'@ instance selection
-- You need a specific instance of this for any instance selectors
-- you may define.
class FWArbitraryC a r | a -> r

-- | Instance selector type for the default (transparent) @'Arbitrary'@
-- instances
data FWDefaultArbitrary = FWDefaultArbitrary deriving (Show, Read)

-- | Instance selector type for transparent @'Arbitrary'@ instances
data FWTransparentArbitrary = FWTransparentArbitrary deriving (Show, Read)

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWArbitrary t a = FWArbitrary

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWCoarbitrary t a = FWCoarbitrary

-- | * Default instance
instance TypeCast r FWTransparentArbitrary => FWArbitraryC (FW t a) r

-- | * Propagated instance
instance FWArbitraryC (FW s a) r => FWArbitraryC (FW (x :*: s) a) r

-- | * Specific @'FWDefaultArbitrary'@ instance
instance FWArbitraryC (FW (FWDefaultArbitrary :*: s) a) FWTransparentArbitrary

-- | * Specific @'FWTransparentArbitrary'@ instance
instance FWArbitraryC (FW (FWTransparentArbitrary :*: s) a)
    FWTransparentArbitrary

-- | ** Implementation instance for @'Arbitrary'@ instance selection
instance Arbitrary a =>
    Apply (Proxy (FWArbitrary t a)) (Proxy FWTransparentArbitrary)
        (Gen (FW t a))
  where
    apply _ _  = fmap FlexiWrap arbitrary

-- | ** Implementation instance for @'Arbitrary'@ instance selection
instance Arbitrary a =>
    Apply (Proxy (FWCoarbitrary t a)) (Proxy FWTransparentArbitrary)
        (FW t a -> WrapCoarbitrary)
  where
    apply _ _  x = WrapCoarbitrary (coarbitrary $ unFlexiWrap x)

-- | * Coordinating instance of @'Arbitrary'@
instance forall t a r. (
            Apply (Proxy (FWArbitrary t a)) (Proxy r) (Gen (FW t a)),
            Apply (Proxy (FWCoarbitrary t a)) (Proxy r)
                (FW t a -> WrapCoarbitrary),
            FWArbitraryC (FW t a) r
        ) =>
        Arbitrary (FW t a) where
    arbitrary = apply (Proxy :: Proxy (FWArbitrary t a)) (Proxy :: Proxy r)
    coarbitrary = unwrapCoarbitrary .
        apply (Proxy :: Proxy (FWCoarbitrary t a)) (Proxy :: Proxy r)

-- Monoid

-- | Analysis class for @'Monoid'@ instance selection
-- You need a specific instance of this for any instance selectors
-- you may define.
class FWMonoid a r | a -> r

-- | Instance selector type for the default (transparent) @'Monoid'@
-- instances
data FWDefaultMonoid = FWDefaultMonoid deriving (Show, Read)

-- | Instance selector type for transparent @'Monoid'@ instances
data FWTransparentMonoid = FWTransparentMonoid deriving (Show, Read)

-- | Instance selector type for dual @'Monoid'@ instances,
-- obtained by swapping the arguments of 'mappend'.
data FWDualMonoid = FWDualMonoid deriving (Show, Read)

-- Internal version of FWDualMonoid, capturing the subsequent
-- instance selectors
data FWDualMonoidI s = FWDualMonoidI deriving (Show, Read)

-- | Instance selector type for instances of the @'Monoid'@ of
-- endomorphisms under composition.
data FWEndoMonoid = FWEndoMonoid deriving (Show, Read)

-- | Instance selector type for instances of the Boolean
-- @'Monoid'@ under conjunction.
data FWAllMonoid = FWAllMonoid deriving (Show, Read)

-- | Instance selector type for instances of the Boolean
-- @'Monoid'@ under disjunction.
data FWAnyMonoid = FWAnyMonoid deriving (Show, Read)

-- | Instance selector type for instances of a numeric
-- @'Monoid'@ under addition.
data FWSumMonoid = FWSumMonoid deriving (Show, Read)

-- | Instance selector type for instances of a numeric
-- @'Monoid'@ under multiplication.
data FWProductMonoid = FWProductMonoid deriving (Show, Read)

-- | Instance selector type for instances of a
-- Maybe @'Monoid'@ returning the leftmost non-Nothing value.
data FWFirstMonoid = FWFirstMonoid deriving (Show, Read)

-- | Instance selector type for instances of a
-- Maybe @'Monoid'@ returning the rightmost non-Nothing value.
data FWLastMonoid = FWLastMonoid deriving (Show, Read)

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWMempty t a = FWMempty

-- | Function identifier type for @'Apply'@.
-- You need a corresponding instance of @'Apply'@ for any
-- instance selectors you may define.
data FWMappend t a = FWMappend

-- | * Default instance
instance TypeCast r FWTransparentMonoid => FWMonoid (FW t a) r

-- | * Propagated instance
instance FWMonoid (FW s a) r => FWMonoid (FW (x :*: s) a) r

-- | * Specific @'FWDefaultMonoid'@ instance
instance FWMonoid (FW (FWDefaultMonoid :*: s) a) FWTransparentMonoid

-- | * Specific @'FWTransparentMonoid'@ instance
instance FWMonoid (FW (FWTransparentMonoid :*: s) a) FWTransparentMonoid

-- | * Specific @'FWDualMonoid'@ instance
instance FWMonoid (FW (FWDualMonoid :*: s) a) (FWDualMonoidI s)

-- | * Specific @'FWEndoMonoid'@ instance
instance FWMonoid (FW (FWEndoMonoid :*: s) a) FWEndoMonoid

-- | * Specific @'FWAllMonoid'@ instance
instance FWMonoid (FW (FWAllMonoid :*: s) a) FWAllMonoid

-- | * Specific @'FWAnyMonoid'@ instance
instance FWMonoid (FW (FWAnyMonoid :*: s) a) FWAnyMonoid

-- | * Specific @'FWSumMonoid'@ instance
instance FWMonoid (FW (FWSumMonoid :*: s) a) FWSumMonoid

-- | * Specific @'FWProductMonoid'@ instance
instance FWMonoid (FW (FWProductMonoid :*: s) a) FWProductMonoid

-- | * Specific @'FWFirstMonoid'@ instance
instance FWMonoid (FW (FWFirstMonoid :*: s) a) FWFirstMonoid

-- | * Specific @'FWLastMonoid'@ instance
instance FWMonoid (FW (FWLastMonoid :*: s) a) FWLastMonoid

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Monoid a =>
    Apply (Proxy (FWMempty t a)) (Proxy FWTransparentMonoid) (FW t a)
  where
    apply _ _  = FlexiWrap mempty

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Monoid a =>
    Apply (Proxy (FWMappend t a)) (Proxy FWTransparentMonoid)
        (FW t a -> FW t a -> FW t a)
  where
    apply _ _  = inFlexiWrap2 mappend

-- | ** Implementation instance for @'Monoid'@ instance selection
instance forall a t s. Monoid (FW s a) =>
    Apply (Proxy (FWMempty t a)) (Proxy (FWDualMonoidI s)) (FW t a)
  where
    apply _ _  = FlexiWrap $ unFlexiWrap me
      where
        me = mempty :: FW s a

-- TODO: Move inCompose2R to Data.Flex.Utils

-- | ** Implementation instance for @'Monoid'@ instance selection
instance forall a t s. Monoid (FW s a) =>
    Apply (Proxy (FWMappend t a)) (Proxy (FWDualMonoidI s))
        (FW t a -> FW t a -> FW t a)
  where
    apply _ _  = inCompose2R unwrap wrap $ flip mappend
      where
        inCompose2R :: (forall v. p v -> q v) -> (q d -> e) ->
            (q b -> q c -> q d) ->
            (p b -> p c -> e)
        inCompose2R down up = inCompose down $ inCompose down up
        unwrap :: FW t b -> FW s b
        unwrap = FlexiWrap . unFlexiWrap
        wrap :: FW s a -> FW t a
        wrap = FlexiWrap . unFlexiWrap

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMempty t (a -> a))) (Proxy FWEndoMonoid)
    (FW t (a -> a))
  where
    apply _ _  = FlexiWrap id

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMappend t (a -> a))) (Proxy FWEndoMonoid)
        (FW t (a -> a) -> FW t (a -> a) -> FW t (a -> a))
  where
    apply _ _  = inFlexiWrap2 (.)

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMempty t Bool)) (Proxy FWAllMonoid) (FW t Bool)
  where
    apply _ _  = FlexiWrap True

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMappend t Bool)) (Proxy FWAllMonoid)
        (FW t Bool -> FW t Bool -> FW t Bool)
  where
    apply _ _  = inFlexiWrap2 (&&)

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMempty t Bool)) (Proxy FWAnyMonoid) (FW t Bool)
  where
    apply _ _  = FlexiWrap False

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMappend t Bool)) (Proxy FWAnyMonoid)
        (FW t Bool -> FW t Bool -> FW t Bool)
  where
    apply _ _  = inFlexiWrap2 (||)

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Num a =>
    Apply (Proxy (FWMempty t a)) (Proxy FWSumMonoid) (FW t a)
  where
    apply _ _  = FlexiWrap 0

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Num a =>
    Apply (Proxy (FWMappend t a)) (Proxy FWSumMonoid)
        (FW t a -> FW t a -> FW t a)
  where
    apply _ _  = inFlexiWrap2 (+)

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Num a =>
    Apply (Proxy (FWMempty t a)) (Proxy FWProductMonoid) (FW t a)
  where
    apply _ _  = FlexiWrap 1

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Num a =>
    Apply (Proxy (FWMappend t a)) (Proxy FWProductMonoid)
        (FW t a -> FW t a -> FW t a)
  where
    apply _ _  = inFlexiWrap2 (*)

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMempty t (Maybe a))) (Proxy FWFirstMonoid)
    (FW t (Maybe a))
  where
    apply _ _  = FlexiWrap Nothing

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMappend t (Maybe a))) (Proxy FWFirstMonoid)
        (FW t (Maybe a) -> FW t (Maybe a) -> FW t (Maybe a))
  where
    apply _ _  = inFlexiWrap2 f
      where
        r@(Just _) `f` _ = r
        Nothing    `f` r = r

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMempty t (Maybe a))) (Proxy FWLastMonoid)
    (FW t (Maybe a))
  where
    apply _ _  = FlexiWrap Nothing

-- | ** Implementation instance for @'Monoid'@ instance selection
instance Apply (Proxy (FWMappend t (Maybe a))) (Proxy FWLastMonoid)
        (FW t (Maybe a) -> FW t (Maybe a) -> FW t (Maybe a))
  where
    apply _ _  = inFlexiWrap2 f
      where
        _ `f` r@(Just _) = r
        r `f` Nothing    = r

-- TODO: Min, Max monoids

-- | * Coordinating instance of @'Monoid'@
instance forall t a r. (
            Apply (Proxy (FWMempty t a)) (Proxy r) (FW t a),
            Apply (Proxy (FWMappend t a)) (Proxy r)
                (FW t a -> FW t a -> FW t a),
            FWMonoid (FW t a) r
        ) =>
        Monoid (FW t a) where
    mempty = apply (Proxy :: Proxy (FWMempty t a)) (Proxy :: Proxy r)
    mappend = apply (Proxy :: Proxy (FWMappend t a)) (Proxy :: Proxy r)

{- TODO:
    Num and it's subclasses
    Bounded, Enum, Ix
    Data, Typeable
    Binary
    NFData
-}

-- end FlexiWrap

-- vim: expandtab:tabstop=4:shiftwidth=4