{-# LANGUAGE DeriveFunctor #-}
module X11Utils(module X11Utils,(<>),foldMap) where
import Data.Monoid
import Data.Foldable(foldMap)
import Control.Monad(replicateM)
import Data.Bits(setBit,shiftR,finiteBitSize)
import Data.Word
import Data.Int(Int16,Int32)
import Data.ByteString(ByteString,index,pack)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C

default (Int)

safeToEnum d n | n>=lo && n<=hi = e
               | otherwise      = d
  where
    e = toEnum n
    lo = fe (minBound `asTypeOf` e)
    hi = fe (maxBound `asTypeOf` e)

byte bs ix = fi (index bs ix)
word16 bs ix =  byte bs ix + 256*byte bs (ix+1)
word32 bs ix = word16 bs ix + 65536*word16 bs (ix+2)

word16x2 r p = (word16 r p,word16 r (p+2))
word32x2 r p = (word32 r p,word32 r (p+4))

int16 r p = fi (word16 r p)::Int16
int16x2 r p = (int16 r p,int16 r (p+2))

int32 r p = fi (word32 r p)::Int32

fi x = fromIntegral x
fe x = fromEnum x
te x = toEnum x

--------------------------------------------------------------------------------

c2w :: Char -> Word8
c2w = convEnum

b2w :: Bool -> Word8
b2w = convEnum

convEnum e = te $ fe e

--------------------------------------------------------------------------------

newtype BitSet a = BitSet {bitWord::Word32} deriving Show

bitset :: (Bounded a,Enum a) => [a] -> BitSet a
bitset xs | lo==0 && hi<finiteBitSize w = BitSet w
  where
    w = foldr (flip setBit . fromEnum) 0 xs
    x:_ = xs
    lo = fromEnum (minBound `asTypeOf` x)
    hi = fromEnum (maxBound `asTypeOf` x)

fromBitSet :: (Bounded a,Enum a) => BitSet a -> [a]
fromBitSet (BitSet w) = from minBound w
  where
    from e 0 = []
    from e w = [e|odd w]++from (succ e) (shiftR w 1)

--------------------------------------------------------------------------------

newtype Getter a = Getter {unGet::ByteString->Int->(Int,a)} deriving Functor

runGet g r =  snd (unGet g r 0)
getFrom r g = runGet g r
getIt r = getFrom r get

atEnd = Getter $ \ r p -> (p,p==B.length r)

instance Applicative Getter where
  pure x = Getter $ \ r p -> (p,x)
  Getter gf <*> Getter gx = Getter $ \ r p0 -> let (p1,f) = gf r p0
                                                   (p2,x) = gx r p1
                                               in (p2,f x)

instance Monad Getter where
  return = pure
  Getter gx >>= fg = Getter $ \ r p0 -> let (p1,x) = gx r p0
                                        in unGet (fg x) r p1

class FromX a where get :: Getter a

instance (FromX a,FromX b) => FromX (a,b) where get = (,) <$> get <*> get

w8  = Getter $ \ r p -> (p+1,index r p)
w16 = join <$> w8 <*> w8 where join lo hi = fi lo+256*fi hi
w32 = join <$> w16 <*> w16 where join lo hi = fi lo+65536*fi hi
i16 = fi <$> w16
i32 = fi <$> w32

w16be :: Getter Word16
w32be :: Getter Word32
w16be = join <$> w8 <*> w8 where join hi lo = fi lo+256*fi hi
w32be = join <$> w16 <*> w16 where join hi lo = fi lo+65536*fi hi

bytes  n = Getter $ \ r p -> (p+n,B.take n (B.drop p r))
unused n = Getter $ \ r p -> (p+n,())
string8 n = C.unpack <$> bytes n
str = string8 . fi =<< w8

two g = (,) <$> g <*> g
list n g = replicateM n g

instance FromX Word8  where get = w8
instance FromX Word16 where get = w16
instance FromX Word32 where get = w32
instance FromX Int16  where get = i16
instance FromX Int32  where get = i32
instance FromX Bool   where get = convEnum <$> w8

--------------------------------------------------------------------------------

{- -- Putter version 1:
type Putter = [Word8]

putWord8 :: Word8 -> Putter
putWord8 w = [w]

put2Word8 :: Word8 -> Word8 -> Putter
put2Word8 w1 w2 = [w1,w2]

putBytes bs = bs

nil = []
packet = pack
-}

-- Putter version 2:
type Putter = Endo [Word8]

putWord8 :: Word8 -> Putter
putWord8 w = Endo (w:)

put2Word8 :: Word8 -> Word8 -> Putter
put2Word8 w1 w2 = Endo $ \ r -> w1:w2:r

putBytes bs = Endo $ \ r -> foldr (:) r bs

nil = Endo id
packet (Endo f) = pack (f [])

--------------------------------------------------------------------------------

class Put a where put :: a -> Putter

instance (Put a,Put b) => Put (a,b) where put (a,b) = put a<>put b
instance (Put a,Put b,Put c) => Put (a,b,c) where put (a,b,c) = put (a,(b,c))
instance Put a => Put [a] where put = foldMap put

instance Put Word8  where put = putWord8
instance Put Word16 where put = putWord16
instance Put Int16  where put = putInt16
instance Put Word32 where put = putWord32

putWord16,putWord16be :: Word16 -> Putter
putWord16 w = put2Word8 (fi w) (fi (shiftR w 8))
putWord16be w = put2Word8 (fi (shiftR w 8)) (fi w)

putWord16x2 (a,b) = putWord16 a<>putWord16 b

putInt16 :: Int16 -> Putter
putInt16 = putWord16 . fromIntegral

putWord32 :: Word32 -> Putter
putWord32 w = putWord16x2 (fi w,fi (shiftR w 16))

putChar8 = putWord8 . c2w