{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.13 2010/04/24 00:47:40 dosuser Exp dosuser $
module Data.Flex.Wrap where

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

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

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

import Data.Flex.Utils (inCompose, inCompose2)

-- begin FlexiWrap

newtype FlexiWrap s a = FlexiWrap {unFlexiWrap :: a}

type FW = FlexiWrap

flexiWrap :: s -> a -> FW s a
flexiWrap _ = FlexiWrap

inFlexiWrap :: (a -> b) -> (FW s a -> FW s b)
inFlexiWrap = inCompose unFlexiWrap FlexiWrap

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)

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

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

class FWIsWrapped a r | a -> r

data FWAlreadyWrapped = FWAlreadyWrapped
data FWNewWrapper = FWNewWrapper

data FWFWrap s a = FWFWrap

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

instance Apply (FWFWrap u a) FWNewWrapper (a -> FW u a) where
    apply _ _ = FlexiWrap
instance Apply (FWFWrap u (FW s a)) FWAlreadyWrapped (FW s a -> FW u a) where
    apply _ _ = FlexiWrap . unFlexiWrap

data FWTag

instance Apply FWTag (FW t a) t
instance TypeCast r TNil => Apply FWTag a r

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

infixl 8 `on`
on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
(op `on` f) x y = f x `op` f y

class FWEq a r | a -> r

data FWDefaultEq = FWDefaultEq

data FWEquals t a = FWEquals

data FWNotEquals t a = FWNotEquals

-- default instance
instance TypeCast r FWDefaultEq => FWEq (FW t a) r

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

instance Eq a => Apply (FWEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool)
  where
    apply _ _ = (==) `on` unFlexiWrap

instance Eq a => Apply (FWNotEquals t a) FWDefaultEq (FW t a -> FW t a -> Bool)
  where
    apply _ _ = (/=) `on` unFlexiWrap

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)

-- end FlexiWrap

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