{-# LANGUAGE OverloadedStrings, TypeSynonymInstances,
             FlexibleInstances, MultiParamTypeClasses #-}

module FRP.Netwire.Input.JavaScript (
        JSInputState,
        JSInputControl,
        JSInput,
        JSInputT,
        Key(..),
        MouseButton(..),
        mkInputControl,
        initialInputState,
        pollJavaScript,
        cursorLocked,
        lockCursor,
        unlockCursor
) where

import qualified Data.IntSet as S
import Control.Applicative
import Control.Monad (when)
import Control.Monad.Trans.State
import Control.Wire.Core
import Data.IORef
import FRP.Netwire.Input hiding (Key, MouseButton)
import FRP.Netwire.Input.JavaScript.Key

import GHCJS.Foreign hiding (Object)
import GHCJS.Foreign.Callback
import GHCJS.Marshal
import GHCJS.Types
import JavaScript.Object.Internal

data JSInputState = JSInputState {
        keyPressedSet :: S.IntSet,
        keyReleasedSet :: S.IntSet,
        mbPressedSet :: S.IntSet,
        mbReleasedSet :: S.IntSet,
        cursorPos :: (Float, Float),
        cursorMovement :: (Float, Float),
        scrollAmount :: (Double, Double),
        hiddenCursor :: Bool,
        lockedCursor :: Bool,
        newCursorMode :: Maybe CursorMode
}

data Event = KeyDown Int | KeyUp Int | MouseDown Int | MouseUp Int
           | MouseMove (Float, Float) (Float, Float) | Wheel (Int, Int)
           | PointerLockChange Bool

data JSInputControl = JSInputControl (IORef [Event]) (IORef Bool) JSVal

type JSInput = State JSInputState
type JSInputT m = StateT JSInputState m

-- | Create a 'JSInputControl' from a DOM element.
mkInputControl :: JSVal -> IO (Maybe JSInputControl)
mkInputControl element | isNull element = return Nothing
mkInputControl element = do eventsVar <- newIORef []
                            ptrLockVar <- newIORef False
                            doc <- document
                            event element eventsVar "keydown" eventKeyDown
                            event element eventsVar "keyup" eventKeyUp
                            event element eventsVar "mousedown" eventMouseDown
                            event element eventsVar "mouseup" eventMouseUp
                            event element eventsVar "mousemove" $
                                    eventMouseMove element
                            event element eventsVar "wheel" eventWheel
                            event doc eventsVar "pointerlockchange" $
                                    const (eventPointerLockChange element)
                            event doc eventsVar "mozpointerlockchange" $
                                    const (eventPointerLockChange element)
                            ptrLockPerformer element ptrLockVar "mouseup"
                            ptrLockPerformer element ptrLockVar "keyup"
                            return . Just $
                                    JSInputControl eventsVar ptrLockVar element

        where event element eventsVar name getEvent =
                do callback <- asyncCallback1 $ \rawEvent ->
                                do event <- getEvent $ Object rawEvent
                                   modifyIORef' eventsVar (event :)
                   addEventListener element name callback

              ptrLockPerformer element ptrLockVar name =
                do callback <- asyncCallback1 $ \_ -> do
                                lock <- atomicModifyIORef' ptrLockVar
                                                           (\x -> (False, x))
                                when lock $ lockCursorRaw element
                   addEventListener element name callback

-- | Use this with 'pollJavaScript' the first time.
initialInputState :: JSInputState
initialInputState = JSInputState {
        keyPressedSet = S.empty,
        keyReleasedSet = S.empty,
        mbPressedSet = S.empty,
        mbReleasedSet = S.empty,
        cursorPos = (0, 0),
        cursorMovement = (0, 0),
        scrollAmount = (0, 0),
        hiddenCursor = False,
        lockedCursor = False,
        newCursorMode = Nothing
        }

-- | Update the 'JSInputState' with the new events.
pollJavaScript :: JSInputState
               -> JSInputControl
               -> IO JSInputState
pollJavaScript is (JSInputControl eventsVar ptrLockVar element) =
        do events <- atomicModifyIORef eventsVar $ \e -> ([], e)

           let is' = foldr compEvent
                           is { scrollAmount = (0, 0)
                              , cursorMovement = (0, 0) }
                           events
               hidden = hiddenCursor is
               locked = lockedCursor is'

           hidden' <- case newCursorMode is of
                           Just cm -> changeCursorMode hidden locked cm
                                                       element ptrLockVar
                           _ -> return hidden

           return is' { hiddenCursor = hidden', newCursorMode = Nothing }

-- | In JavaScript, you can lock the pointer only after the user releases a
-- mouse button or a key. This means that 'cursorMode' (with 'CursorMode'Reset')
-- and 'mouseMickies' will not actually lock the pointer, but will schedule
-- the pointer lock request for the next interaction from the user.
-- In particular, 'mouseMickies' will behave like 'mouseCursor' if the pointer
-- is not locked.
--
-- This wire, which inhibits if the pointer is not locked, is
-- useful if you want to know if you're still waiting for the user to lock the
-- pointer, and if the user manually unlocked it.
cursorLocked :: (Monoid e, Monad m) => Wire s e (JSInputT m) a a
cursorLocked = mkGen_ $ \x -> boolToEither x . lockedCursor <$> get
        where boolToEither _ False = Left mempty
              boolToEither x True = Right x

-- | Manually schedule cursor lock.
lockCursor :: JSInputControl -> IO ()
lockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar True

-- | Manually unlock the cursor.
unlockCursor :: JSInputControl -> IO ()
unlockCursor (JSInputControl _ ptrLockVar _) = writeIORef ptrLockVar False
                                               >> unlockCursorRaw

changeCursorMode :: Bool -> Bool -> CursorMode
                 -> JSVal -> IORef Bool -> IO Bool
changeCursorMode hidden locked cm element ptrLockVar = 
        do case (locked, cm == CursorMode'Reset || cm == CursorMode'Disabled) of
                (True, False) -> writeIORef ptrLockVar False >> unlockCursorRaw
                (False, True) -> writeIORef ptrLockVar True
                _ -> return ()

           case (hidden, cm == CursorMode'Hidden) of
                (True, False) -> showCursor element >> return False
                (False, True) -> hideCursor element >> return True
                _ -> return hidden

compEvent :: Event -> JSInputState -> JSInputState
compEvent (KeyDown k) is | S.member k $ keyReleasedSet is = is
                         | otherwise = is { keyPressedSet =
                                                S.insert k $ keyPressedSet is }
compEvent (KeyUp k) is =
        is { keyPressedSet = S.delete k $ keyPressedSet is
           , keyReleasedSet = S.delete k $ keyReleasedSet is }
compEvent (MouseDown k) is | S.member k $ mbReleasedSet is = is
                           | otherwise = is { mbPressedSet =
                                                S.insert k $ mbPressedSet is }
compEvent (MouseUp k) is =
        is { mbPressedSet = S.delete k $ mbPressedSet is
           , mbReleasedSet = S.delete k $ mbReleasedSet is }
compEvent (MouseMove (cx, cy) (dmx, dmy)) is =
        let (mx0, my0) = cursorMovement is
        in is { cursorPos = (cx, cy)
              , cursorMovement = (mx0 + dmx, my0 + dmy) }
compEvent (Wheel (x, y)) is =
        let (dx, dy) = (fromIntegral x, fromIntegral y)
            (x0, y0) = scrollAmount is
        in is { scrollAmount = (x0 + dx, y0 + dy) }
compEvent (PointerLockChange locked) is = is { lockedCursor = locked }

instance Monad m => MonadMouse MouseButton (JSInputT m) where
        setCursorMode cm = modify $ \is -> is { newCursorMode = Just cm }
        mbIsPressed mb = S.member (fromMouseButton mb) . mbPressedSet <$> get
        releaseButton mb = modify $
                \is -> is { mbReleasedSet = S.insert (fromMouseButton mb) $
                                                     mbReleasedSet is
                          , mbPressedSet = S.delete (fromMouseButton mb) $
                                                    mbPressedSet is }
        cursor = (<$> get) $ \is -> if lockedCursor is
                                    then cursorMovement is
                                    else cursorPos is
        scroll = scrollAmount <$> get

instance Monad m => MonadKeyboard Key (JSInputT m) where
        keyIsPressed k = do kp <- keyPressedSet <$> get
                            return $ any (flip S.member kp) (fromKey k)
        releaseKey k = modify $
                \is -> is { keyReleasedSet = foldr S.insert
                                                   (keyReleasedSet is)
                                                   (fromKey k)
                          , keyPressedSet = foldr S.delete
                                                  (keyPressedSet is)
                                                  (fromKey k)
                          }

eventKeyDown :: Object -> IO Event
eventKeyDown ev = KeyDown <$> prop "keyCode" ev

eventKeyUp :: Object -> IO Event
eventKeyUp ev = KeyUp <$> prop "keyCode" ev

eventMouseDown :: Object -> IO Event
eventMouseDown ev = MouseDown <$> prop "button" ev

eventMouseUp :: Object -> IO Event
eventMouseUp ev = MouseUp <$> prop "button" ev

eventMouseMove :: JSVal -> Object -> IO Event
eventMouseMove elem ev@(Object evVal) =
        do width <- fi <$> prop "clientWidth" (Object elem)
           height <- fi <$> prop "clientHeight" (Object elem)
           clientX <- fi <$> prop "clientX" ev
           clientY <- fi <$> prop "clientY" ev
           movementX <- fi <$> movementX evVal
           movementY <- fi <$> movementY evVal
           return $ MouseMove ( clientX * 2 / width - 1
                              , clientY * 2 / height - 1)
                              ( movementX * 2 / width
                              , movementY * 2 / height )
        where fi = fromIntegral :: Int -> Float

eventWheel :: Object -> IO Event
eventWheel ev = Wheel <$> ((,) <$> prop "deltaX" ev
                               <*> prop "deltaY" ev)

eventPointerLockChange :: JSVal -> IO Event
eventPointerLockChange elem = PointerLockChange <$> isPointerLockElement elem

prop :: FromJSVal a => JSString -> Object -> IO a
prop s o = unsafeGetProp s o >>= fromJSValUnchecked

foreign import javascript unsafe "$1.addEventListener($2, $3)"
        addEventListener :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> IO ()

foreign import javascript unsafe " if ($1.requestPointerLock)\
                                 \     $1.requestPointerLock()\
                                 \ else\
                                 \     $1.mozRequestPointerLock()"
        lockCursorRaw :: JSVal -> IO ()

foreign import javascript unsafe " if (document.exitPointerLock)\
                                 \     document.exitPointerLock()\
                                 \ else\
                                 \     document.mozExitPointerLock()"
        unlockCursorRaw :: IO ()

foreign import javascript unsafe "$1.style.cursor = 'none'"
        hideCursor :: JSVal -> IO ()

foreign import javascript unsafe "$1.style.cursor = 'auto'"
        showCursor :: JSVal -> IO ()

foreign import javascript unsafe " document.pointerLockElement === $1 ||\
                                 \ document.mozPointerLockElement === $1"
        isPointerLockElement :: JSVal -> IO Bool

foreign import javascript unsafe "$r = document" document :: IO JSVal

foreign import javascript unsafe "$1.movementX || $1.mozMovementX || 0"
        movementX :: JSVal -> IO Int

foreign import javascript unsafe "$1.movementY || $1.mozMovementY || 0"
        movementY :: JSVal -> IO Int