{-# HLINT ignore "Use camelCase" #-}

module Wetterhorn.Core
  ( WState (..),
    WConfig (..),
    SurfaceState (..),
    W,
    getWConfig,
    getWState,
    runW,
    Wetterhorn,
    initWetterhorn,
    wio,
    incrementState,
    readWState,
    defaultConfig,
    requestHotReload,
    ctxConfig,
    KeyEvent (..),
    KeyState (..),
  )
where

import Control.Arrow (first)
import Control.Exception
import Control.Monad (when)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as CH
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Foreign (Ptr, StablePtr, Word32, castForeignPtr, newStablePtr, ptrToIntPtr)
import Numeric (showHex)
import Text.Printf
import Wetterhorn.Core.ForeignInterface (ForeignInterface)
import qualified Wetterhorn.Core.ForeignInterface as ForeignInterface
import Wetterhorn.WlRoots (WlrInputDevice, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
import Data.Char (chr, ord)

data WContext = WContext
  { ctxForeignInterface :: ForeignInterface,
    ctxConfig :: WConfig
  }

-- This is the OpaqueState passed to the harness.
type Wetterhorn = StablePtr (WContext, WState)

requestHotReload :: W ()
requestHotReload = do
  fi <- ctxForeignInterface <$> getWContext
  wio $ ForeignInterface.requestHotReload fi

requestLog :: String -> W ()
requestLog str = do
  fi <- ctxForeignInterface <$> getWContext
  wio $ ForeignInterface.requestLog fi str

requestExit :: Int -> W ()
requestExit ec = do
  fi <- ctxForeignInterface <$> getWContext
  wio $ ForeignInterface.requestExit fi ec

initWetterhorn :: WConfig -> IO Wetterhorn
initWetterhorn conf = do
  foreignInterface <- ForeignInterface.getForeignInterface
  newStablePtr (WContext foreignInterface conf, WState "this is a string" 0)

data WState = WState
  { someString :: String,
    integer :: Int
  }
  deriving (Show, Read)

data SurfaceState = Map | Unmap | Destroy deriving (Eq, Ord, Show, Enum)

data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord)

data KeyEvent = KeyEvent
  { timeMs :: Word32,
    keycode :: Word32,
    state :: KeyState,
    modifiers :: Word32,
    keysym :: Word32,
    codepoint :: Char,
    device :: Ptr WlrInputDevice
  }
  deriving (Show, Ord, Eq)

data WConfig = WConfig
  { keybindingHandler :: KeyEvent -> W Bool,
    surfaceHandler :: SurfaceState -> Ptr () -> W ()
  }

defaultBindings :: Map (KeyState, Word32, Word32) (W ())
defaultBindings =
  Map.fromList
    [ ((KeyPressed, 0x8, sym 'r'), requestHotReload),
      ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
      ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
      ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
      ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
      ((KeyPressed, 0x8, sym 'q'), requestExit 0)
    ]

  where
    sym = fromIntegral . ord

defaultConfig :: WConfig
defaultConfig =
  WConfig
    { keybindingHandler = \keyEvent -> do
        i <- incrementState
        seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext

        wio $ printf "%d - Got %s\n" i (show keyEvent)
        maybe
          ( wio $ do
              wlrSeatSetKeyboard seatPtr (device keyEvent)
              wlrSeatKeyboardNotifyKey
                seatPtr
                (timeMs keyEvent)
                (keycode keyEvent)
                ( case state keyEvent of
                    KeyReleased -> 0
                    _ -> 1
                )

              return True
          )
          (fmap (const True))
          $ Map.lookup
            (state keyEvent, modifiers keyEvent, keysym keyEvent)
            defaultBindings,
      surfaceHandler = \state ptr -> wio (printf "Surface %s is %s\n" (showHex (ptrToIntPtr ptr) "") (show state))
    }

readWState :: ByteString -> IO WState
readWState bs =
  catch
    (return $ read (CH.unpack bs))
    ( \e ->
        let _ = (e :: SomeException) in return (WState "" 0)
    )

newtype W a = W ((WContext, WState) -> IO (a, WState))

instance Functor W where
  fmap mfn (W fn) = W $ fmap (first mfn) <$> fn

instance Applicative W where
  pure a = W $ \(_, s) -> return (a, s)
  mfn <*> ma = do
    fn <- mfn
    fn <$> ma

instance Monad W where
  (W fntoa) >>= fnmb = W $ \(config, state) -> do
    (a, state') <- fntoa (config, state)
    let W fntob = fnmb a
    fntob (config, state')

getWContext :: W WContext
getWContext = W pure

getWConfig :: W WConfig
getWConfig = ctxConfig <$> getWContext

getWState :: W WState
getWState = W $ \(_, s) -> pure (s, s)

runW :: W a -> (WContext, WState) -> IO (a, WState)
runW (W fn) = fn

incrementState :: W Int
incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1))

wio :: IO a -> W a
wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)