{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Wayland.Protocols.Core.WLOutput
  ( Subpixel(..)
  , Transform(..)
  , Mode(..)
  , Geometry(..)
  , Request(..)
  , Event(..)
  , Handle(..)
  ) where

import Data.Data (Typeable)
import Wayland.Server (ResourceClass(..), RequestClass, InterfaceDesc(..), MessageDesc(..), ArgumentDesc(..), Nullability(..), ObjectID, EventClass, marshalInt, marshalString, marshalUInt)
import Data.Hashable (Hashable(..))

newtype Handle = Handle ObjectID
  deriving (Show, Eq, Ord, Hashable)

reqRelease :: MessageDesc
reqRelease = MessageDesc { msgName         = "release"
                         , msgSignature    = []
                         , msgSince        = 3
                         , msgIsDestructor = True
                         }

evGeometry :: MessageDesc
evGeometry = MessageDesc { msgName         = "geometry"
                         , msgSignature    = [ ArgumentInt
                                             , ArgumentInt
                                             , ArgumentInt
                                             , ArgumentInt
                                             , ArgumentInt
                                             , ArgumentString NotNull
                                             , ArgumentString NotNull
                                             , ArgumentInt
                                             ]
                         , msgSince        = 1
                         , msgIsDestructor = False
                         }

evMode :: MessageDesc
evMode = MessageDesc { msgName         = "mode"
                     , msgSignature    = [ ArgumentUInt
                                         , ArgumentInt
                                         , ArgumentInt
                                         , ArgumentInt
                                         ]
                     , msgSince        = 1
                     , msgIsDestructor = False
                     }

evDone :: MessageDesc
evDone = MessageDesc { msgName         = "done"
                     , msgSignature    = []
                     , msgSince        = 2
                     , msgIsDestructor = False
                     }

evScale :: MessageDesc
evScale = MessageDesc { msgName         = "scale"
                      , msgSignature    = [ ArgumentInt ]
                      , msgSince        = 2
                      , msgIsDestructor = False
                      }

evName :: MessageDesc
evName = MessageDesc { msgName         = "name"
                     , msgSignature    = [ ArgumentString NotNull ]
                     , msgSince        = 4
                     , msgIsDestructor = False
                     }

evDescription :: MessageDesc
evDescription = MessageDesc { msgName         = "description"
                            , msgSignature    = [ ArgumentString NotNull ]
                            , msgSince        = 4
                            , msgIsDestructor = False
                            }

instance ResourceClass Handle where
  type ResourceEvent   Handle = Event
  type ResourceRequest Handle = Request
  objectID (Handle h) = h
  fromID = Handle
  interface _ = InterfaceDesc { ifName     = "wl_output"
                              , ifVersion  = 4
                              , ifRequests = [ reqRelease ]
                              , ifEvents   = [ evGeometry
                                             , evMode
                                             , evDone
                                             , evScale
                                             , evName
                                             , evDescription ]
                              }

  demarshalRequest r 0 = do
    pure (ReqRelease r)
  demarshalRequest _ _ = fail "Unknown opcode."

  marshalEvent _ (EvGeometry p) = do
    marshalInt    (x p)
    marshalInt    (y p)
    marshalInt    (physicalWidth p)
    marshalInt    (physicalHeight p)
    marshalInt    (fromEnum (subpixel p))
    marshalString (make p)
    marshalString (model p)
    marshalInt    (fromEnum (transform p))
    pure 0
  marshalEvent _ (EvMode p) = do
    marshalUInt (fromBitSet (flags p))
    marshalInt  (width p)
    marshalInt  (height p)
    marshalInt  (refresh p)
    pure 1
  marshalEvent _ EvDone = do
    pure 2
  marshalEvent _ (EvScale p) = do
    marshalInt p
    pure 3
  marshalEvent _ (EvName p) = do
    marshalString p
    pure 4
  marshalEvent _ (EvDescription p) = do
    marshalString p
    pure 5

  requestSignature _ (ReqRelease _) = reqRelease

  eventSignature _ (EvGeometry _)    = evGeometry
  eventSignature _ (EvMode _)        = evMode
  eventSignature _  EvDone           = evDone
  eventSignature _ (EvScale _)       = evScale
  eventSignature _ (EvName _)        = evName
  eventSignature _ (EvDescription _) = evDescription

data Subpixel
  = SubpixelUnknown
  | SubpixelNone
  | SubpixelHorizontalRgb
  | SubpixelHorizontalBgr
  | SubpixelVerticalRgb
  | SubpixelVerticalBgr
  deriving (Show, Enum)

data Transform
  = TransformNormal
  | TransformNormal90
  | TransformNormal180
  | TransformNormal270
  | TransformFlipped
  | TransformFlipped90
  | TransformFlipped180
  | TransformFlipped270
  deriving (Show, Enum)

data ModeFlags
  = ModeFlags { current   :: Bool
              , preferred :: Bool
              }
  deriving (Show)

fromBitSet :: ModeFlags -> Word
fromBitSet _ = 0

data Mode
  = Mode { flags   :: ModeFlags
         , width   :: Int
         , height  :: Int
         , refresh :: Int
         }
  deriving (Show)

data Geometry
  = Geometry { x              :: Int
             , y              :: Int
             , physicalWidth  :: Int
             , physicalHeight :: Int
             , subpixel       :: Subpixel
             , make           :: String
             , model          :: String
             , transform      :: Transform
             }
  deriving (Show)

data Request
  = ReqRelease Handle
  deriving (Typeable, Show)

instance RequestClass Request where

data Event
  = EvGeometry    Geometry
  | EvMode        Mode
  | EvScale       Int
  | EvName        String
  | EvDescription String
  | EvDone
  deriving (Typeable, Show)

instance EventClass Event where