{-# language LambdaCase          #-}
{-# language OverloadedStrings   #-}
{-# language RecursiveDo         #-}
{-# language ScopedTypeVariables #-}

module Main where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (SomeException)
import Control.Lens
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Writer.Strict
import Data.Aeson (Value)
import Data.Aeson.Lens
import Data.Foldable (fold, for_)
import Data.Maybe
import Data.String (fromString)
import Data.Text.Lens (unpacked)
import Network.HTTP.Simple
import Reactive.Banana
import Reactive.Banana.Frameworks
import Text.HTML.TagSoup

import qualified Termbox.Banana as Termbox

main :: IO ()
main =
  Termbox.run_
    (Termbox.InputModeEsc Termbox.MouseModeNo)
    Termbox.OutputModeNormal
    moment

moment
  :: Event Termbox.Event
  -> Behavior (Int, Int)
  -> MomentIO (Behavior Termbox.Scene, Event ())
moment eEvent bSize = mdo
  eTick :: Event () <-
    makeTickEvent

  requestQueue :: TQueue String <-
    liftIO newTQueueIO

  eSearchBox :: Event String <-
    makeSearchBoxEvent eKey

  reactimate
    ((atomically . writeTQueue requestQueue . reverse) <$> eSearchBox)

  let
    eEmptySearchBox :: Event String
    eEmptySearchBox =
      filterE null eSearchBox

  bSearchBox :: Behavior String <-
    stepper "" eSearchBox

  (eSearchResults, fireSearchResults) <-
    newEvent

  liftIO . void . forkIO $
    runHttpRequestThread
      requestQueue
      fireSearchResults

  bSearchResults :: Behavior (Either SomeException [Value]) <-
    stepper
      (Right [])
      (unionWith
        const
        (Right [] <$ eEmptySearchBox)
        eSearchResults)

  bSpinnerFrame :: Behavior (Maybe Int) <-
    accumB Nothing (unions
      [ ((\query ->
            if null query
              then const Nothing
              else const (Just 1))
          <$> eSearchBox)
      , const Nothing <$ eSearchResults
      , const Nothing <$ eEmptySearchBox
      , fmap (+1) <$ whenE (isJust <$> bSpinnerFrame) eTick
      ])

  let
    bCells :: Behavior Termbox.Cells
    bCells =
      render
        <$> bHeight
        <*> bSearchBox
        <*> bSearchResults
        <*> bSpinnerFrame

  let
    bCursor :: Behavior Termbox.Cursor
    bCursor =
      (\height searchBox -> Termbox.Cursor (length searchBox + 2) height)
        <$> bHeight
        <*> bSearchBox

  let
    bScene :: Behavior Termbox.Scene
    bScene =
      Termbox.Scene
        <$> bCells
        <*> bCursor

  pure (bScene, () <$ filterE (== Termbox.KeyEsc) eKey)

  where
    eKey :: Event Termbox.Key
    eKey =
      filterJust (eventAsKey <$> eEvent)

    bHeight :: Behavior Int
    bHeight =
      snd <$> bSize

makeTickEvent :: MomentIO (Event ())
makeTickEvent = do
  (e, f) <- newEvent
  liftIO . void . forkIO . forever $ do
    f ()
    threadDelay 100000
  pure e

makeSearchBoxEvent
  :: MonadMoment m
  => Event Termbox.Key
  -> m (Event String)
makeSearchBoxEvent eKey =
  accumE
    ""
    (unions
      [ (:) <$> filterJust (keyAsChar <$> eKey)
      , (' ' :) <$  filterE (== Termbox.KeySpace) eKey
      , safeTail <$ filterE (== Termbox.KeyBackspace2) eKey
      ])

runHttpRequestThread
  :: TQueue String -- ^ Request queue
  -> (Either SomeException [Value] -> IO ()) -- ^ Response callback
  -> IO ()
runHttpRequestThread requestQueue respond =
  loop Nothing
  where
    loop :: Maybe (Async [Value]) -> IO ()
    loop maybeInFlightRequest =
      join . atomically $
        (do
          query <- readTQueue requestQueue
          pure $ do
            for_ maybeInFlightRequest $ \inFlightRequest ->
              forkIO (cancel inFlightRequest)
            if null query
              then
                loop Nothing
              else do
                inFlightRequest <- async (performHoogleSearch query)
                loop (Just inFlightRequest))
        <|>
        (case maybeInFlightRequest of
          Nothing ->
            retry
          Just inFlightRequest -> do
            response <- waitCatchSTM inFlightRequest
            pure $ do
              respond response
              loop Nothing)

render
  :: Int
  -> String
  -> Either SomeException [Value]
  -> Maybe Int
  -> Termbox.Cells
render height searchBox searchResults spinnerFrame =
  fold
    [ case searchResults of
        Left ex ->
          renderSearchResultsError height ex
        Right results ->
          renderSearchResults height results
            & execWriterT
            & (`evalState` 0)
    , renderSearchBox height searchBox spinnerFrame
    ]

renderSearchBox :: Int -> String -> Maybe Int -> Termbox.Cells
renderSearchBox height searchBox spinnerFrame =
  renderString 0 (height-1) (promptChar : ' ' : reverse searchBox)
  where
    promptChar :: Char
    promptChar =
      case spinnerFrame of
        Nothing ->
          'λ'
        Just n  ->
          let
            cs =
              "⣧⣏⡟⠿⢻⣹⣼⣶"
          in
            cs !! (n `mod` length cs)

renderSearchResults
  :: Int
  -> [Value]
  -> WriterT Termbox.Cells (State Int) ()
renderSearchResults height = \case
  [] ->
    pure ()

  result : results -> do
    row <- get

    let
      ss = searchResultToLines result

    when (row + length ss < height-1) $ do
      for_ (zip [row..] ss) $ \(r, s) ->
        tell (renderString 0 r s)
      modify' (+ (length ss + 1))
      renderSearchResults height results

renderSearchResultsError
  :: Int
  -> SomeException
  -> Termbox.Cells
renderSearchResultsError height ex =
  ex
    & show
    & lines
    & take height
    & zip [0..]
    & foldMap (\(row, line) -> renderString 0 row line)

searchResultToLines :: Value -> [String]
searchResultToLines result =
  case result ^?! key "type" of
    "" ->
      unwords
        [ "[" ++ resultPackage result ++ "]"
        , "[" ++ resultModule result ++ "]"
        , resultItem result
        ]
        : map ("  " ++) (resultDocs result)

    "module" ->
      unwords
        [ "[" ++ resultPackage result ++ "]"
        , "[" ++ drop 7 (resultItem result) ++ "]"
        ]
        : map ("  " ++) (resultDocs result)

    "package" ->
      ("[" ++ drop 8 (resultItem result) ++ "]")
        : map ("  " ++) (resultDocs result)

    _ ->
      error (show result)

resultPackage :: Value -> String
resultPackage result =
  result
    ^?! key "package"
      . key "name"
      . _String
      . unpacked

resultModule :: Value -> String
resultModule result =
  result
    ^?! key "module"
      . key "name"
      . _String
      . unpacked

resultItem :: Value -> String
resultItem result =
  result
    ^?! key "item"
      . _String
      . unpacked
      . to htmlToText

resultDocs :: Value -> [String]
resultDocs result =
  result
    ^?! key "docs"
      . _String
      . unpacked
      . to htmlToText
      . to lines
      . to collapseLines

  where
    collapseLines :: [String] -> [String]
    collapseLines = \case
      [] ->
        []

      [""] ->
        []

      "" : ss ->
        case collapseLines ss of
          "" : ts -> "" : ts
          ts      -> "" : ts

      s : ss ->
        s : collapseLines ss

htmlToText :: String -> String
htmlToText html =
  concat $ do
    TagText text <- parseTags html
    pure text


renderString :: Int -> Int -> String -> Termbox.Cells
renderString col row =
  foldMap (\(i, c) -> Termbox.set i row (Termbox.Cell c mempty mempty)) .
    zip [col..]

performHoogleSearch :: String -> IO [Value]
performHoogleSearch query =
  getResponseBody <$> httpJSON (fromString searchUrl)
  where
    searchUrl :: String
    searchUrl =
      "https://hoogle.haskell.org?mode=json&count=10&hoogle=" ++ query

eventAsKey :: Termbox.Event -> Maybe Termbox.Key
eventAsKey = \case
  Termbox.EventKey k _ -> Just k
  _ -> Nothing

keyAsChar :: Termbox.Key -> Maybe Char
keyAsChar = \case
  Termbox.KeyChar c -> Just c
  _ -> Nothing

safeTail :: [a] -> [a]
safeTail = \case
  [] -> []
  _:xs -> xs