{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Main where


import           Control.Lens
import           Control.Monad               (void, when)
import           Control.Monad.IO.Class      (liftIO)
import           Data.Map                    as Map (Map, insert, lookup,
                                                     toDescList)
import           Data.Text                   (Text, pack, unpack)
import           Data.Time                   (UTCTime, defaultTimeLocale,
                                              formatTime, getCurrentTime)
import           Language.Javascript.JSaddle (FromJSVal (fromJSVal), JSM,
                                              MonadJSM, fun, js, js1, js2, jsg,
                                              liftJSM, obj, strictEqual, (<#))
import           Prelude                     hiding (div, span)
import qualified Text.Show.Pretty            as Pretty
import           UnliftIO                    (TVar, atomically, modifyTVar,
                                              newTVarIO)

import           Shpadoinkle                 (Html, flagProp, shpadoinkle, text)
import           Shpadoinkle.Backend.ParDiff (runParDiff)
import           Shpadoinkle.Html
import           Shpadoinkle.Run             (runJSorWarp)


default (Text)


newtype History = History { unHistory :: Text }
  deriving (Eq, Ord, Show)


data Model = Model
  { _history :: Map UTCTime History
  , _active  :: Maybe UTCTime
  , _sync    :: Bool
  } deriving (Eq, Show)
makeLenses ''Model


emptyModel :: Model
emptyModel = Model mempty Nothing True


listenForOutput :: TVar Model -> JSM ()
listenForOutput model = void $ jsg "chrome" ^. (js "runtime" . js "onMessage" . js1 "addListener" (fun $ \ _ _ args -> do
  let x = Prelude.head args
  t <- x ^. js "type"
  isRight <- strictEqual t "shpadoinkle_output_state"
  when isRight $ do
    msg <- x ^. js "msg"
    now <- liftIO getCurrentTime
    history' <- maybe (error "how could this not be a string") History <$> fromJSVal msg
    atomically . modifyTVar model $ heard now history'))


heard :: UTCTime -> History -> Model -> Model
heard now history' m = m & history %~ insert now history' &
  case m ^. active of
    Just _ | m ^. sync -> active ?~ now
    Nothing            -> active ?~ now
    Just _             -> id


row :: MonadJSM m => Maybe UTCTime -> UTCTime -> History -> Html m Model
row sel k history' = div "record"
  [ div [ className "time"
        , class' [("active", sel == Just k)]
        ]
     [ span_ [ text . pack $ formatTime defaultTimeLocale "%X%Q" k ]
     , button [ onClick $ (sync .~ False) . (active ?~ k) ] [ "Inspect" ]
     , button [ onClickM_ . liftJSM $ sendHistory history' ] [ "Send" ]
     ]
  ]


sendHistory :: History -> JSM ()
sendHistory (History history') = void $ do
  tabId <- jsg "chrome" ^. (js "devtools" . js "inspectedWindow" . js "tabId")

  msg <- obj
  (msg <# "type") "shpadoinkle_set_state"
  (msg <# "msg") history'

  void $ jsg "chrome" ^. (js "tabs" . js2 "sendMessage" tabId msg)


prettyHtml :: Int -> Pretty.Value -> Html m a
prettyHtml depth = \case
  Pretty.Con con [] -> div "con-uniary" $ string con
  Pretty.Con con slots -> details [ className "con-wrap", ("open", flagProp $ depth < 3) ]
    [ summary "con" $ string con
    , div (withDepth "con-children") $ prettyHtml (depth + 1) <$> slots
    ]
  Pretty.Rec rec fields ->
    details (withDepth "rec-wrap")
    [ summary "rec" $ string rec
    , dl "rec" $ (\(n, v)->
        [ dt_ $ string $ n <> " = "
        , dd_ [ prettyHtml (depth + 1) v ]
        ]) =<< fields
    ]
  Pretty.InfixCons _ _ -> text "Infix Constructors are not currently supported"
  Pretty.Neg x     -> div "neg" [ "¬", prettyHtml depth x ]
  Pretty.Ratio n d -> div "ratio" [ prettyHtml depth n, "/", prettyHtml depth d ]
  Pretty.Tuple xs  -> prettyHtml depth $ Pretty.Con "(,)" xs
  Pretty.List []   -> prettyHtml depth $ Pretty.Con "[]" []
  Pretty.List xs   -> ul "list" $ li_.pure.prettyHtml (depth +1) <$> xs
  Pretty.String ss -> div "string" $ string ss
  Pretty.Float n   -> div "float" $ string n
  Pretty.Integer n -> div "integer" $ string n
  Pretty.Char c    -> div "char" $ string c
  where string = pure . text . pack
        withDepth x = [ class' [ x, "depth-" <> pack (show depth) ] ]


syncState :: Model -> Model
syncState m =
  m & sync .~ True & active .~ (m ^. history . to (g . toDescList))
  where g ((x,_):_) = Just x
        g _         = Nothing


panel :: MonadJSM m => Model -> Html m Model
panel m = div "wrapper"
  [ div "current-state" $ case _active m >>= flip Map.lookup (_history m) of
      Just history' -> [ maybe (text "failed to parse value") (prettyHtml 0) . Pretty.parseValue . unpack $ unHistory history' ]
      _             -> [ "No State" ]
  , div "history" $ button
    [ onClick syncState
    , className "sync-button"
    , class' [ ("sync", m ^. sync) ]
    ] [ "Sync State" ] : (book <> [clear])
  ]
  where book = uncurry (m ^. active . to row) <$> Map.toDescList (m ^. history)
        clear = a [ className "clear", onClick $ const emptyModel ] [ "Clear History" ]


app :: JSM ()
app = do
  model <- liftIO $ newTVarIO emptyModel
  listenForOutput model
  shpadoinkle id runParDiff emptyModel model panel getBody


main :: IO ()
main = runJSorWarp 8080 app