flexiwrap-smallcheck-0.0.1: Data/Flex/Serial/Wrap.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverlappingInstances #-}
-- .$Header: c:/Source/Haskell/Wrapper/smallcheck/Data/Flex/Serial/RCS/Wrap.hs,v 1.1 2011/09/21 00:13:15 dosuser Exp dosuser $

-- | Instance selectors and machinery for @'Serial'@ instances for FlexiWrap

module Data.Flex.Serial.Wrap (
    -- * Instance selectors and machinery for @'Serial'@ instances for FlexiWrap
    -- ** Instance selectors
    FWDefaultSerial(..),
    FWTransparentSerial(..),
    -- ** Machinery for @'Serial'@ instances
    FWSerial,
    FWSeries(..),
    FWCoseries(..)
) where

import Test.SmallCheck (Serial(..), Series)

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

import Data.Flex.Serial (WrapCoseries(..), seriesMap)
import Data.Flex.Utils (result, argument)
import Data.Flex.Wrap (FlexiWrap(..), FW)

-- Serial

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

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

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

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

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

-- | * Default instance
instance TypeCast r FWTransparentSerial => FWSerial (FW t a) r

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

-- | * Specific @'FWDefaultSerial'@ instance
instance FWSerial (FW (FWDefaultSerial :*: s) a) FWTransparentSerial

-- | * Specific @'FWTransparentSerial'@ instance
instance FWSerial (FW (FWTransparentSerial :*: s) a)
    FWTransparentSerial

-- | ** Implementation instance for @'Serial'@ instance selection
instance Serial a =>
    Apply (Proxy (FWSeries t a)) (Proxy FWTransparentSerial)
        (Series (FW t a))
  where
    apply _ _  = seriesMap FlexiWrap series

-- | ** Implementation instance for @'Serial'@ instance selection
instance Serial a =>
    Apply (Proxy (FWCoseries t a)) (Proxy FWTransparentSerial)
        (WrapCoseries (FW t a))
  where
    apply _ _ =
        WrapCoseries ((result . seriesMap . argument) unFlexiWrap coseries)

-- | * Coordinating instance of @'Serial'@
instance forall t a r. (
            Apply (Proxy (FWSeries t a)) (Proxy r) (Series (FW t a)),
            Apply (Proxy (FWCoseries t a)) (Proxy r)
                (WrapCoseries (FW t a)),
            FWSerial (FW t a) r
        ) =>
        Serial (FW t a) where
    series = apply (Proxy :: Proxy (FWSeries t a)) (Proxy :: Proxy r)
    coseries = unwrapCoseries $
        apply (Proxy :: Proxy (FWCoseries t a)) (Proxy :: Proxy r)

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