Ticket #4355: tcBug.hs

{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, Rank2Types, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards #-}

module TcBug where

import Control.Arrow
import Control.Monad.Trans
import Control.Monad.Reader
import Data.Typeable
import Data.Maybe

class (Eq t, Typeable t) => Transformer t a | t -> a where
    transform :: (LayoutClass l a) => t -> l a ->
        (forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b

class HList c a where
    find :: (Transformer t a) => c -> t -> Maybe Int

class Typeable a => Message a

data (LayoutClass l a) => EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)

unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
unEL (EL x _) k = k x

transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
transform' t (EL l det) = transform t l (\l' det' -> EL l' (det . det'))

data Toggle a = forall t. (Transformer t a) => Toggle t
    deriving (Typeable)

instance (Typeable a) => Message (Toggle a)

data MultiToggle ts l a = MultiToggle{
    currLayout :: EL l a,
    currIndex :: Maybe Int,
    transformers :: ts
}

instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where

class Show (layout a) => LayoutClass layout a where
    handleMessage :: layout a -> SomeMessage -> IO (Maybe (layout a))
    handleMessage l  = return . pureMessage l

    pureMessage :: layout a -> SomeMessage -> Maybe (layout a)
    pureMessage _ _  = Nothing

instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where
    handleMessage mt m
        | Just (Toggle t) <- fromMessage m
        , i@(Just _) <- find (transformers mt) t
            = case currLayout mt of
                EL l det -> do
                    l' <- fromMaybe l `fmap` handleMessage l (SomeMessage ReleaseResources)
                    return . Just $
                        mt {
                            currLayout = (if cur then id else transform' t) (EL (det l') id),
                            currIndex = if cur then Nothing else i
                        }
                    where cur = (i == currIndex mt)
        | otherwise
            = case currLayout mt of
                EL l det -> fmap (fmap (\x -> mt { currLayout = EL x det })) $
                    handleMessage l m

data LayoutMessages = ReleaseResources
    deriving (Typeable, Eq)

instance Message LayoutMessages

data SomeMessage = forall a. Message a => SomeMessage a

fromMessage :: Message m => SomeMessage -> Maybe m
fromMessage (SomeMessage m) = cast m