{-# LANGUAGE ViewPatterns #-}

module Wetterhorn.Layout.Combine where

import Data.Typeable
import Wetterhorn.Constraints
import Wetterhorn.Core.W

data (|||) a b = Comb LR a b
  deriving (Typeable, Read, Show)

data Next = Next
  deriving (Typeable)

data Reset = Reset
  deriving (Typeable)

(|||) :: a -> b -> (a ||| b)
a ||| b = Comb L a b

data LR = L | R deriving (Read, Show, Ord, Eq, Enum)

instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where
  handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r)
  handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r)
  handleMessage mesg (Comb L l r) =
    Comb L <$> handleMessage mesg l <*> pure r
  handleMessage mesg (Comb R l r) =
    Comb L l <$> handleMessage mesg r

instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
  -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH
  -- the left and right constraints.
  type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b

  runLayout as (Comb R r l) = do
    (r', ret) <- runLayout as r
    return (Comb R r' l, ret)
  runLayout as (Comb L r l) = do
    (l', ret) <- runLayout as l
    return (Comb R r l', ret)

  serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r))
  readLayout str = Comb lr <$> l <*> r
    where
      (Comb lr (readLayout -> l) (readLayout -> r)) = read str

  description (Comb _ l r) = description l ++ " ||| " ++ description r