module Wetterhorn.Core.W where

import Control.Arrow (Arrow (first))
import Control.Monad.RWS (MonadIO (liftIO), MonadReader, MonadState)
import Control.Monad.Reader (ReaderT (runReaderT))
import Control.Monad.State (StateT (runStateT))
import Data.Data (Typeable, cast)
import Data.Kind (Constraint, Type)
import Data.Set (Set)
import Foreign (StablePtr)
import Text.Read
import Wetterhorn.Core.KeyEvent
import Wetterhorn.Core.SurfaceEvent
import Wetterhorn.Foreign
import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
import Wetterhorn.StackSet hiding (layout)

data RationalRect = RationalRect Rational Rational Rational Rational

-- | Wrapper for a message. Messages are sent to layout and layouts are supposed
-- to handle them. This hides a typeable parameter.
data Message where
  Message :: (Typeable a) => a -> Message

-- | casts a message to a type.
fromMessage :: (Typeable a) => Message -> Maybe a
fromMessage (Message t) = cast t

-- | Wraps a type in a message.
toMessage :: (Typeable a) => a -> Message
toMessage = Message

-- | Types of this class "lay out" windows by assigning rectangles and handle
-- messages.
class (Typeable l) => LayoutClass l where
  -- | Constraints on the type to lay out. Sometimes a layout requires the 'a'
  -- type to be "Ord", other times "Eq", this is the mechanism by which this
  -- constraint is expressed.
  type C l :: Type -> Constraint

  -- | Executes the layout on some windows in a pure way. Returns a list of
  -- windows to their assigned rectangle.
  pureLayout :: (C l a) => [a] -> l -> [(a, RationalRect)]
  pureLayout as _ = map (,RationalRect 0 0 0 0) as

  -- | Runs the layout in an impure way returning a modified layout and the list
  -- of windows to their rectangles under a monad.
  runLayout :: (C l a) => [a] -> l -> W (l, [(a, RationalRect)])
  runLayout as l = return (l, pureLayout as l)

  -- | Handles a message in a pure way. Returns the new layout after handling
  -- the message.
  pureMessage :: Message -> l -> l
  pureMessage _ = id

  -- | Handles a message in an impure way.
  handleMessage :: Message -> l -> W l
  handleMessage m = return . pureMessage m

  readLayout :: String -> Maybe l
  default readLayout :: (Read l) => String -> Maybe l
  readLayout = readMaybe

  serializeLayout :: l -> String
  default serializeLayout :: (Show l) => l -> String
  serializeLayout = show

  description :: l -> String
  default description :: (Show l) => l -> String
  description = show

-- A Layout which hides the layout parameter under an existential type and
-- asserts the layout hidden can work with Window types.
data WindowLayout
  = forall l a. (LayoutClass l, C l a, a ~ Window) => WindowLayout l

runWindowLayout :: [Window] -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l

handleWindowMessage :: Message -> WindowLayout -> W WindowLayout
handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l

-- | Using the 'Layout' as a witness, parse existentially wrapped windows
-- from a 'String'.
readWindowLayout :: WindowLayout -> String -> WindowLayout
readWindowLayout (WindowLayout l) s
  | (Just x) <- readLayout s =
      WindowLayout (asTypeOf x l)
readWindowLayout l _ = l

serializeWindowLayout :: WindowLayout -> String
serializeWindowLayout (WindowLayout l) = serializeLayout l

type ScreenId = ()

type ScreenDetail = ()

type Tag = String

newtype Window = Window (TypedIntPtr ())
  deriving (Eq, Ord, Show, Read)

type Wetterhorn = StablePtr (Context, State)

data Context = Context
  { ctxForeignInterface :: ForeignInterface,
    ctxConfig :: Config WindowLayout
  }

defaultConfig :: Config ()
defaultConfig =
  Config
    { keyHook = \_ -> return (),
      surfaceHook = \_ -> return (),
      layout = ()
    }

data Config l = Config
  { keyHook :: KeyEvent -> W (),
    surfaceHook :: SurfaceEvent -> W (),
    layout :: l
  }

data State = State
  { mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
    allWindows :: Set Window
  }

initColdState :: WindowLayout -> IO State
initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty

marshalState :: State -> String
marshalState (State mapped allWindows) =
  show
    ( mapLayout serializeWindowLayout mapped,
      allWindows
    )

demarshalState :: WindowLayout -> String -> State
demarshalState witness str = State mapped allWindows
  where
    (mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str

newtype W a = W (ReaderT Context (StateT State IO) a)
  deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO)

runW :: W a -> (Context, State) -> IO (a, State)
runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st

wio :: IO a -> W a
wio = liftIO