Bits.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Language.GLSL.Internal.Bits where

data B = O | I
  deriving (Show, Eq)

class Bits a where
  fill :: B -> a
  flat :: a -> [B]
  unflat :: [B] -> Maybe (a, [B])

instance Bits B where
  fill b = b
  flat a = [a]
  unflat (x:xs) = Just (x, xs)
  unflat _      = Nothing
instance (Bits a,Bits b) => Bits (a,b) where
  fill b = (fill b,fill b)
  flat (a,b) = flat a ++ flat b
  unflat xs = do
    (a,xsa) <- unflat xs
    (b,xsb) <- unflat xsa
    return ((a,b),xsb)
instance (Bits a,Bits b,Bits c) => Bits (a,b,c) where
  fill b = (fill b,fill b,fill b)
  flat (a,b,c) = flat a ++ flat b ++ flat c
  unflat xs = do
    (a,xsa) <- unflat xs
    (b,xsb) <- unflat xsa
    (c,xsc) <- unflat xsb
    return ((a,b,c),xsc)
instance (Bits a,Bits b,Bits c,Bits d) => Bits (a,b,c,d) where
  fill b = (fill b,fill b,fill b,fill b)
  flat (a,b,c,d) = flat a ++ flat b ++ flat c ++ flat d
  unflat xs = do
    (a,xsa) <- unflat xs
    (b,xsb) <- unflat xsa
    (c,xsc) <- unflat xsb
    (d,xsd) <- unflat xsc
    return ((a,b,c,d),xsd)
instance (Bits a,Bits b,Bits c,Bits d, Bits e) => Bits (a,b,c,d,e) where
  fill b = (fill b,fill b,fill b,fill b,fill b)
  flat (a,b,c,d,e) = flat a ++ flat b ++ flat c ++ flat d ++ flat e
  unflat xs = do
    (a,xsa) <- unflat xs
    (b,xsb) <- unflat xsa
    (c,xsc) <- unflat xsb
    (d,xsd) <- unflat xsc
    (e,xse) <- unflat xsd
    return ((a,b,c,d,e),xse)

zero, one :: Bits a => a
zero = fill O
one = fill I

class Expandable a b where
  expand :: a -> b

instance Expandable a a where
  expand x = x
-- TODO: can this be more generic?
instance Expandable (B,B) (B,B,B,B,B) where
  expand (a,b) = expand (a,b,O)
instance Expandable (B,B,B) (B,B,B,B,B) where
  expand (a,b,c) = expand (a,b,c,O)
instance Expandable (B,B,B,B) (B,B,B,B,B) where
  expand (a,b,c,d) = expand (a,b,c,d,O)