{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExtendedDefaultRules       #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE ViewPatterns               #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

#ifndef ghcjs_HOST_OS
{-# LANGUAGE StandaloneDeriving         #-}
#endif


{-|
   This backend is to serve as a canonical representation of a well-behaved
   backend. Defining well-behaved in the context of web development
   is rather difficult and complex.

   The rules of a backend are informal. Roughly, if we give the backend
   some Html, we expect it to update the DOM at runtime in the way we expect.

   Since this is canonical, all other backends are expected to behave
   identically to this one. If differences exist they should be patched
   so that we retain renderer polymorphism, such that we can change out
   the renderer of our application; without updating the application logic
   with confidence it will behave as expected.
-}


module Shpadoinkle.Backend.ParDiff
  ( ParDiffT (..)
  , runParDiff
  , stage
  ) where


import           Control.Applicative         (Alternative)
import           Control.Compactable         (Compactable (traverseMaybe))
import           Control.Lens                ((^.))
import           Control.Monad.Base          (MonadBase (..), liftBaseDefault)
import           Control.Monad.Catch         (MonadCatch, MonadThrow)
import           Control.Monad.Reader        (MonadIO, MonadReader (ask),
                                              MonadTrans (..), ReaderT (..),
                                              guard, void)
import           Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
                                              MonadTransControl,
                                              defaultLiftBaseWith,
                                              defaultRestoreM)
import           Data.Align                  (Semialign (align))
import           Data.Foldable               (traverse_)
import           Data.Kind                   (Type)
import           Data.Map                    (Map)
import qualified Data.Map                    as M
import           Data.Monoid                 ((<>))
import           Data.Once                   (Once, newOnce, runOnce)
import           Data.Text                   (Text, intercalate)
import           Data.These                  (These (That, These, This))
import           Data.Traversable            (for)
import           GHC.Generics                (Generic)
import           Language.Javascript.JSaddle (FromJSVal (fromJSValUnchecked),
                                              JSVal, MakeObject (makeObject),
                                              Object, ToJSString (toJSString),
                                              ToJSVal (toJSVal), eval, fun, js1,
                                              js2, jsg, jsg2, liftJSM,
                                              strictEqual, unsafeGetProp,
                                              unsafeSetProp)
import           UnliftIO                    (MonadUnliftIO (..), TVar,
                                              UnliftIO (UnliftIO, unliftIO),
                                              withUnliftIO)
import           UnliftIO.Concurrent         (forkIO)
import           UnliftIO.STM                (STM, atomically)

import           Shpadoinkle                 (Backend (..), Continuation,
                                              Html (..), JSM, MonadJSM,
                                              Prop (..), RawEvent (RawEvent),
                                              RawNode (RawNode), hoist,
                                              type (~>), writeUpdate)


default (Text)


newtype ParDiffT model m a = ParDiffT { unParDiff :: ReaderT (TVar model) m a }
  deriving
  ( Functor
  , Applicative
  , Alternative
  , Monad
  , MonadIO
  , MonadReader (TVar model)
  , MonadTrans
  , MonadTransControl
  , MonadThrow
  , MonadCatch
  )


#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (ParDiffT model m)
#endif


instance MonadBase n m => MonadBase n (ParDiffT model m) where
  liftBase = liftBaseDefault


instance MonadBaseControl n m => MonadBaseControl n (ParDiffT model m) where
  type StM (ParDiffT model m) a = ComposeSt (ParDiffT model) m a
  liftBaseWith = defaultLiftBaseWith
  restoreM = defaultRestoreM


instance MonadUnliftIO m => MonadUnliftIO (ParDiffT r m) where
  {-# INLINE askUnliftIO #-}
  askUnliftIO = ParDiffT . ReaderT $ \r ->
                withUnliftIO $ \u ->
                return (UnliftIO (unliftIO u . flip runReaderT r . unParDiff))
  {-# INLINE withRunInIO #-}
  withRunInIO inner =
    ParDiffT . ReaderT $ \r ->
    withRunInIO $ \run' ->
    inner (run' . flip runReaderT r . unParDiff)


-- | 'ParDiffT' is a @newtype@ of 'ReaderT', this is the 'runReaderT' equivalent.
runParDiff :: TVar model -> ParDiffT model m ~> m
runParDiff t (ParDiffT r) = runReaderT r t


data ParVNode :: Type -> Type where
  ParNode     :: Once JSM RawNode -> Text -> Map Text (ParVProp a) -> [ParVNode a] -> ParVNode a
  ParPotato   :: Once JSM RawNode -> ParVNode a
  ParTextNode :: Once JSM RawNode -> Text -> ParVNode a


instance Show (ParVNode a) where
  show = \case
    ParNode _ t ps cs -> "ParNode _ " <> show t <> " " <> show ps <> " " <> show cs
    ParPotato _       -> "ParPotato _"
    ParTextNode _ t   -> "ParTextNode _ " <> show t


data ParVProp a
  = ParVText Text
  | ParVData JSVal
  | ParVListen (RawNode -> RawEvent -> JSM (Continuation JSM a))
  | ParVFlag Bool
  | ParVPotato (RawNode -> JSM (STM (Continuation JSM a)))
  deriving Generic


instance Show (ParVProp a) where
  show = \case
    ParVData   _ -> "ParVData _"
    ParVPotato _ -> "ParVPotato _"
    ParVText   t -> "ParVText " <> show t
    ParVListen _ -> "ParVListen _"
    ParVFlag   b -> "ParVFlag " <> show b


props :: Monad m => (m ~> JSM) -> TVar a -> Map Text (Prop (ParDiffT a m) a) -> RawNode -> JSM ()
props toJSM i ps (RawNode raw) = do
  raw' <- makeObject raw
  void . traverse (uncurry $ prop toJSM i raw') $ M.toList ps


prop :: Monad m => (m ~> JSM) -> TVar a -> Object -> Text -> Prop (ParDiffT a m) a -> JSM ()
prop toJSM i raw k = \case
  PData d     -> setProp' raw k d
  PPotato p   -> setProptado i (fmap (fmap (hoist (toJSM . runParDiff i))) . p) raw
  PText t     -> setProp' raw k t
  PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i)
                                         <$> f x y) raw k
  PFlag True  -> setProp' raw k =<< toJSVal True
  PFlag False -> return ()


setProp' :: ToJSVal t => Object -> Text -> t -> JSM ()
setProp' raw' k t = do
  let k' = toJSString k
  old <- unsafeGetProp k' raw'
  t' <- toJSVal t
  b <- strictEqual old t'
  if b then return () else unsafeSetProp (toJSString k) t' raw'


setProptado :: forall a. TVar a -> (RawNode -> JSM (STM (Continuation JSM a))) -> Object -> JSM ()
setProptado i f o = do
  elm <- RawNode <$> toJSVal o
  stm <- f elm
  let go = atomically stm >>= writeUpdate i >> go
  void $ forkIO go


setListener :: TVar a -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -> Object -> Text -> JSM ()
setListener i m o k = do
  elm <- RawNode <$> toJSVal o
  setProp' o ("on" <> k) . fun $ \_ _ -> \case
    e:_ -> do
      x <- m elm (RawEvent e)
      writeUpdate i x
    _ -> return ()


getRaw :: ParVNode a -> Once JSM RawNode
getRaw = \case
  ParNode mk _ _ _ -> mk
  ParPotato mk     -> mk
  ParTextNode mk _ -> mk


setRaw :: Once JSM RawNode -> ParVNode a -> ParVNode a
setRaw r = \case
  ParNode _ a b c -> ParNode r a b c
  ParPotato _     -> ParPotato r
  ParTextNode _ a -> ParTextNode r a


appendChild :: RawNode -> ParVNode a -> JSM (ParVNode a)
appendChild (RawNode raw) pn = do
  let raw' = getRaw pn
  RawNode r <- runOnce raw'
  void $ raw ^. js1 "appendChild" r
  return pn


makeProp :: Monad m => (m ~> JSM) -> TVar a -> Prop (ParDiffT a m) a -> JSM (ParVProp a)
makeProp toJSM i = \case
  PText t     -> return $ ParVText t
  PData t     -> return $ ParVData t
  PPotato p   -> return . ParVPotato $ fmap (fmap (hoist (toJSM . runParDiff i))) . p
  PListener m -> return . ParVListen $ \x y -> hoist (toJSM . runParDiff i) <$> m x y
  PFlag b     -> return $ ParVFlag b


setup' :: JSM () -> JSM ()
setup' cb = do
  void $ eval $ intercalate "\n"
    [ " window.deleteProp = (k, obj) => {"
    , "   delete obj[k]"
    , " }"
    , " window.container = document.createElement('div')"
    , " document.body.appendChild(container)"
    ]
  cb


voidJSM :: MonadJSM m => JSM a -> m ()
voidJSM = void . liftJSM


setFlag :: MonadJSM m => Object -> Text -> Bool -> m ()
setFlag obj' k b = if b then
    voidJSM $ setProp' obj' k =<< toJSVal True
  else case k of
    "checked"  -> voidJSM $ setProp' obj' k =<< toJSVal False
    "disabled" -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"
    _          -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'


managePropertyState :: MonadJSM m => TVar a -> Object -> Map Text (ParVProp a) -> Map Text (ParVProp a) -> m ()
managePropertyState i obj' old new' = void $ do
  -- The following step may be necessary if the old DOM and the new VDOM both have checked == False
  -- but the user just checked this checkbox / radio button and the browser set its
  -- checked property to true without setting its checked attribute.
  -- As far as we know this issue only occurs with the checked property.
  -- As far as we know this issue only occurs with the value properties of input controls,
  -- which include but are not necessarily limited to:
  --  * The value properties of input, select, and textarea elements
  --  * The checked properties of input type={checkbox,radio} elements
  --  * The src properties of image elements
  --  * The files properties of file elements
  -- Of these properties, checked is the only one where we know that the absence of the attribute
  -- in both the old and new (V)DOMs is consistent with the property needing to be updated
  -- because the property was updated with the corresponding attribute being absent the whole time.
  maybe (return ()) (const . voidJSM $ setProp' obj' "checked" =<< toJSVal False)
    $ M.lookup "checked" new' >>= guard . (\case { ParVFlag False -> True; _ -> False })
  M.toList (align old new') `for` \(k, x) -> case x of
    -- only old had it, delete
    This _                 -> case k of
      "className" -> voidJSM $ obj' ^. js1 "removeAttribute" "class"
      "htmlFor"   -> voidJSM $ obj' ^. js1 "removeAttribute" "for"
      "style"     -> voidJSM $ obj' ^. js1 "removeAttribute" "style"
      "checked"   -> voidJSM $ setProp' obj' k =<< toJSVal False
      "disabled"  -> voidJSM $ obj' ^. js1 "removeAttribute" "disabled"
      _           -> voidJSM $ jsg2 "deleteProp" (toJSString k) obj'
    That  (ParVPotato p)   -> voidJSM $ p . RawNode =<< toJSVal obj'
    That  (ParVData j)     -> voidJSM $ setProp' obj' k j
    -- new text prop, set
    That  (ParVText t)     -> voidJSM $ setProp' obj' k =<< toJSVal t
    -- changed text prop, set
    These (ParVText t)
          (ParVText t')
                | t /= t'  -> voidJSM $ setProp' obj' k =<< toJSVal t'
    -- new flag prop, set
    That  (ParVFlag b)  -> setFlag obj' k b
    -- changed flag prop, set
    These (ParVFlag t)
          (ParVFlag t')
                | t /= t' -> setFlag obj' k t'
    -- new listener, set
    That  (ParVListen h)  -> voidJSM $ setListener i h obj' k
    -- listeners are uncomparable in any useful way
    These (ParVListen _)
          (ParVListen h)  -> voidJSM $ setListener i h obj' k
    -- no change, do nothing
    These _ _              -> return ()


patchChildren
  :: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
  => MonadJSM m
#endif
  => Show a
  => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a]
patchChildren parent@(RawNode p) old new'' =
  traverseMaybe (\case

    This child -> do
      RawNode c <- lift . liftJSM . runOnce $ getRaw child
      voidJSM $ p ^. js1 "removeChild" c
      return Nothing

    That child -> do
      RawNode c <- lift . liftJSM . runOnce $ getRaw child
      voidJSM $ p ^. js1 "appendChild" c
      return $ Just child

    These old' new' ->
      Just <$> patch' parent (Just old') new'

  ) (align old new'')


patch'
  :: MonadUnliftIO m
#ifndef ghcjs_HOST_OS
  => MonadJSM m
#endif
  => Show a
  => RawNode -> Maybe (ParVNode a) -> ParVNode a -> ParDiffT a m (ParVNode a)
patch' parent old new' = do
  i <- ask
  case (old, new') of

    -- text node did not change
    (Just old'@(ParTextNode _ t)
              , ParTextNode _ t')
                         | t == t' -> return old'


    -- text node changed
    (Just (ParTextNode raw _)
         , ParTextNode _ t) -> do

      RawNode r <- liftJSM $ runOnce raw
      obj' <- liftJSM $ makeObject r
      liftJSM $ setProp' obj' "nodeValue" =<< toJSVal t
      return $ setRaw raw new'


    -- node may have changed
    (Just (ParNode raw name ps cs)
         , ParNode _   name' ps' cs')
                 | name == name' -> do

      raw'@(RawNode r) <- liftJSM $ runOnce raw
      obj' <- liftJSM $ makeObject r
      managePropertyState i obj' ps ps'
      cs'' <- patchChildren raw' cs cs'
      return $ ParNode raw name ps' cs''


    -- node definitely has changed
    (Just old', _) -> do

      RawNode p <- return parent
      RawNode r <- lift . liftJSM . runOnce $ getRaw old'
      RawNode c <- lift . liftJSM . runOnce $ getRaw new'
      _ <- liftJSM $ p ^. js2 "replaceChild" c r
      return new'


    -- first patch
    (Nothing, _) -> do

      RawNode p <- return parent
      RawNode c <- lift . liftJSM . runOnce $ getRaw new'
      _ <- liftJSM $ p ^. js1 "appendChild" c
      return new'


interpret'
  :: MonadJSM m
  => MonadUnliftIO m
  => Eq a
  => Show a
  => (m ~> JSM) -> Html (ParDiffT a m) a -> ParDiffT a m (ParVNode a)
interpret' toJSM = \case

  TextNode t -> do
    raw <- liftJSM . newOnce $ do
      doc <- jsg "document"
      RawNode <$> doc ^. js1 "createTextNode" t
    return $ ParTextNode raw t

  Potato p -> do
    raw <- liftJSM $ newOnce p
    return $ ParPotato raw

  Node name (M.fromList -> ps) cs -> do
    i <- ask

    let makeNode = do
          doc <- jsg "document"
          elm <- RawNode <$> doc ^. js1 "createElement" name
          props toJSM i ps elm
          return elm

    cs' <- traverse (interpret toJSM) cs
    raw <- liftJSM . newOnce $ do
      node <- makeNode
      traverse_ (appendChild node) cs'
      return node

    p <- liftJSM $ makeProp toJSM i `traverse` ps

    return $ ParNode raw name p cs'


instance
  ( MonadUnliftIO m
  , MonadJSM m
  , Eq a
  , Show a ) => Backend (ParDiffT a) m a where
  type VNode (ParDiffT a) m = ParVNode a
  interpret = interpret'
  setup = setup'
  patch = patch'


-- | Get the DOM node produced by 'setup'.
stage :: FromJSVal b => MonadJSM m => ParDiffT a m b
stage = liftJSM $ fromJSValUnchecked =<< jsg "container"