{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
module EventHandlingSpec where

import Prelude hiding (div)
import Control.Concurrent.STM.TChan
import Control.Monad.STM (atomically)
import Control.Monad.IO.Class
import Test.Hspec.QuickCheck
import Test.Hspec
import Test.QuickCheck
import Data.Aeson
import Data.Aeson.TH

import TreeGenerator
import Component
import EventHandling
import Events
import PrepareTree
import Rendering

type Id a = a -> a

data TestAction = Up | Down

$(deriveJSON defaultOptions ''TestAction)

data SingleConstructor = SingleConstructor

$(deriveJSON (defaultOptions{tagSingleConstructors=True}) ''SingleConstructor)

{-

Just to clean up tests a bit. I dunno if this approach would work to clean
up the main event loop as well, since it calls "runEvent" (re: applying the event)
in a non-forked fashioned.  If you try void . forkIO you end up back in m a -> IO a
hell.

-}
apply :: MonadIO m => TChan Event -> Event -> Purview parentAction action m -> m (Purview parentAction action m)
apply eventBus newStateEvent@StateChangeEvent {} component =
  pure $ applyNewState newStateEvent component
apply eventBus fromEvent@Event {event=eventKind} component =
  case eventKind of
    "newState" -> pure $ applyNewState fromEvent component
    _          -> do
      events <- runEvent fromEvent component
      liftIO $ mapM_ (atomically . writeTChan eventBus) events
      pure component

spec :: SpecWith ()
spec = parallel $ do
  describe "apply" $ do

    it "changes state" $ do
      let
        actionHandler :: String -> Int -> Int
        actionHandler "up" _ = 1
        actionHandler _    _ = 0

        handler :: Purview () a IO
        handler =
          simpleHandler (0 :: Int)
            actionHandler
            (Text . show)

      render handler
        `shouldBe`
        "<div handler=\"null\">0</div>"

      chan <- newTChanIO

      let event' = Event { event="click", message="up", location=Nothing }

      appliedHandler <- apply chan event' handler

      stateEvent <- atomically $ readTChan chan

      show stateEvent `shouldBe` show (StateChangeEvent (id :: Int -> Int) Nothing)

      afterState <- apply chan stateEvent appliedHandler

      render afterState
        `shouldBe`
        "<div handler=\"null\">1</div>"

    it "works for clicks across many different trees" $
      property $ \x -> do
        let event = Event { event="click", message="up", location=Nothing }
        chan <- newTChanIO

        component <- apply chan event (x :: Purview String String IO)
        render component `shouldContain` "always present"

    it "works for setting state across many different trees" $
      property $ \x -> do
        let event = Event { event="newState", message="up", location=Just [] }
        chan <- newTChanIO

        component <- apply chan event (x :: Purview String String IO)
        -- this tests 2 things
        -- 1. that it fully goes down the tree
        -- 2. the component remains the same, since the event doesn't
        --    have a location that matches anything
        component `shouldBe` x

    it "works with typed messages" $ do
      let
        actionHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])
        actionHandler Up   _ = (const 1, [])
        actionHandler Down _ = (const 0, [])

        handler =
          messageHandler (0 :: Int)
            actionHandler
            (Text . show)

      render handler
        `shouldBe`
        "<div handler=\"null\">0</div>"

      chan <- newTChanIO

      let event' = Event { event="click", message=toJSON Up, location=Nothing }

      appliedHandler <- apply chan event' handler

      stateEvent <- atomically $ readTChan chan

      afterState <- apply chan stateEvent appliedHandler

      render afterState
        `shouldBe`
        "<div handler=\"null\">1</div>"

    it "works after sending an event that did not match anything" $ do
      let
        actionHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])
        actionHandler Up   _ = (const 1, [])
        actionHandler Down _ = (const 0, [])

        handler =
          messageHandler (0 :: Int)
            actionHandler
            (Text . show)

      chan <- newTChanIO

      let event0 = Event { event="init", message="init", location=Nothing }

      appliedHandler0 <- apply chan event0 handler
      render appliedHandler0
        `shouldBe`
        "<div handler=\"null\">0</div>"

      let event1 = Event { event="init", message=toJSON Up, location=Nothing }

      appliedHandler1 <- apply chan event1 appliedHandler0

      stateEvent <- atomically $ readTChan chan
      appliedHandler2 <- apply chan stateEvent appliedHandler1

      render appliedHandler2
        `shouldBe`
        "<div handler=\"null\">1</div>"

    it "works with a nested attribute" $ do
      let
        childHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])
        childHandler Up   _ = (const 1, [Parent "hello"])
        childHandler Down _ = (const 0, [])

        parentHandler :: String -> String -> (Id String, [DirectedEvent String String])
        parentHandler "hello" _ = (const "bye", [])
        parentHandler "bye" _ = (const "hello", [])
        parentHandler str _ = (const str, [])

        styledContainer = style "font-size: 10px;" . div

        handler =
          messageHandler ("" :: String) parentHandler
            $ \message ->
                styledContainer
                [ text message
                , messageHandler (0 :: Int)
                    childHandler
                    (text . show)
                ]

        component = handler

      chan <- newTChanIO

      let
        locatedGraph = fst $ prepareTree component
        event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }

      afterEvent1 <- apply chan event1 locatedGraph

      receivedEvent1 <- atomically $ readTChan chan
      show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))

      receivedEvent2 <- atomically $ readTChan chan
      receivedEvent2 `shouldBe` Event {event = "internal", message = String "hello", location = Just []}

    describe "sending events" $ do

      it "can send an event to a parent" $ do
        let
          childHandler :: TestAction -> Int -> (Id Int, [DirectedEvent String TestAction])
          childHandler Up   _ = (const 1, [Parent "hello"])
          childHandler Down _ = (const 0, [])

          parentHandler :: String -> String -> (Id String, [DirectedEvent String String])
          parentHandler "hello" _ = (const "bye", [])
          parentHandler "bye" _ = (const "hello", [])
          parentHandler str _ = (const str, [])

          handler =
            messageHandler ("" :: String) parentHandler
              $ \message ->
                  div
                  [ text message
                  , messageHandler (0 :: Int)
                      childHandler
                      (text . show)
                  ]

        chan <- newTChanIO

        let locatedGraph = fst $ prepareTree handler

        render locatedGraph `shouldBe` "<div handler=\"[]\"><div><div handler=\"[1,0]\">0</div></div></div>"

        let event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }

        afterEvent1 <- apply chan event1 locatedGraph

        receivedEvent1 <- atomically $ readTChan chan
        show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))

        receivedEvent2 <- atomically $ readTChan chan
        -- correctly targeted to the parent
        receivedEvent2 `shouldBe` Event {event = "internal", message = String "hello", location = Just []}


      it "can send an event to self" $ do
        let
          childHandler :: TestAction -> Int -> (Int -> Int, [DirectedEvent String TestAction])
          childHandler Up   _ = (const 1, [Self Down])
          childHandler Down _ = (const 0, [])

          parentHandler :: String -> String -> (String -> String, [DirectedEvent String String])
          parentHandler "hello" _ = (const "bye", [])
          parentHandler "bye" _ = (const "hello", [])
          parentHandler str _ = (const str, [])

          handler =
            messageHandler ("" :: String) parentHandler
              $ \message ->
                  div
                  [ text message
                  , messageHandler (0 :: Int)
                      childHandler
                      (text . show)
                  ]

        chan <- newTChanIO

        let locatedGraph = fst $ prepareTree handler

        render locatedGraph `shouldBe` "<div handler=\"[]\"><div><div handler=\"[1,0]\">0</div></div></div>"

        let event1 = Event { event="click", message=toJSON Up, location=Just [1, 0] }

        afterEvent1 <- apply chan event1 locatedGraph

        receivedEvent1 <- atomically $ readTChan chan
        show receivedEvent1 `shouldBe` show (StateChangeEvent (id :: Int -> Int) (Just [1, 0]))

        receivedEvent2 <- atomically $ readTChan chan
        -- correctly targeted to self
        receivedEvent2 `shouldBe` Event {event = "internal", message = String "Down", location = Just [1,0]}


main :: IO ()
main = hspec spec