{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}

module Main where

import           Protolude
import           Control.Lens ((^.), (.~), (%~))
import           Control.Lens.TH (makeLenses)
import qualified Data.Map as Map
import qualified Data.List as Lst
import qualified Data.Time as Tm
import qualified Data.Text as Txt
import qualified Data.Text.Encoding as TxtE
import qualified Data.ByteString as BS
import qualified Data.Vector as Vec
import           Brick ((<+>), (<=>))
import qualified Brick as B
import qualified Brick.BChan as BCh
import qualified Brick.Focus as BF
import qualified Brick.AttrMap as BA
import qualified Brick.Widgets.List as BL
import qualified Brick.Widgets.Edit as BE
import qualified Brick.Widgets.Border as BB
import qualified Brick.Widgets.Border.Style as BBS
import           Control.Concurrent (threadDelay, forkIO)
import qualified Graphics.Vty as V
import qualified Graphics.Vty.Input.Events as K
import           System.FilePath ((</>))
import qualified System.Directory as Dir
import qualified Hoogle as H
import qualified System.Process.Typed as PT
import qualified Data.ByteString.Lazy as BSL


-- | Events that can be sent
-- | Here there is just one event for updating the time
newtype Event = EventUpdateTime Tm.LocalTime

-- | Names use to identify each of the controls
data Name = TypeSearch
          | TextSearch
          | ListResults
          deriving (Show, Eq, Ord)

-- | Sort order
data SortBy = SortNone
            | SortAsc
            | SortDec
            deriving (Eq)


-- | State of the brick app. Contains the controls and any other required state
data BrickState = BrickState { _stEditType :: !(BE.Editor Text Name)      -- ^ Editor for the type to search for
                             , _stEditText :: !(BE.Editor Text Name)      -- ^ Editor for a text search in the results
                             , _stTime :: !Tm.LocalTime                   -- ^ The current time
                             , _stFocus :: !(BF.FocusRing Name)           -- ^ Focus ring - a circular list of focusable controls
                             , _stResults :: [H.Target]                   -- ^ The last set of search results from hoohle
                             , _stResultsList :: !(BL.List Name H.Target) -- ^ List for the search results
                             , _stSortResults :: SortBy                   -- ^ Current sort order for the results
                             , _stDbPath :: FilePath                      -- ^ Hoogle DB path
                             , _yankCommand :: Text                       -- ^ Command to run to copy text to the clipboard 
                             , _yankArgs :: Text                          -- ^ Args for the yank command
                             }

makeLenses ''BrickState


-- | Defines how the brick application will work / handle events
app :: B.App BrickState Event Name
app = B.App { B.appDraw = drawUI
            , B.appChooseCursor = B.showFirstCursor
            , B.appHandleEvent = handleEvent
            , B.appStartEvent = pure
            , B.appAttrMap = const theMap
            }


main :: IO ()
main = do
  -- Use the default hoogle DB. This may not exist because
  --  1) hoogle generate was never called
  --  2) the system hoogle is a different version from the package used here
  dbPath <- H.defaultDatabaseLocation
  Dir.doesFileExist dbPath >>= \case
    True -> runBHoogle dbPath
    False -> do
      putText ""
      putText "bhoogle error: "
      putText "   default hoogle database not found"
      putText $ "     at " <> Txt.pack dbPath
      putText "   You can create the database by installing hoogle and running"
      putText "     hoogle generate"
      putText ""

 
runBHoogle :: FilePath -> IO ()
runBHoogle dbPath = do
  chan <- BCh.newBChan 5 -- ^ create a bounded channel for events

  -- Send a tick event every 1 seconds with the current time
  -- Brick will send this to our event handler which can then update the stTime field
  void . forkIO $ forever $ do
    t <- getTime 
    BCh.writeBChan chan $ EventUpdateTime t
    threadDelay $ 1 * 1000000

  -- Initial current time value
  t <- getTime

  -- Settings
  settings <- loadSettings

  -- Construct the initial state values
  let st = BrickState { _stEditType = BE.editor TypeSearch (Just 1) ""
                      , _stEditText = BE.editor TextSearch (Just 1) ""
                      , _stResultsList = BL.list ListResults Vec.empty 1
                      , _stTime = t
                      , _stFocus = BF.focusRing [TypeSearch, TextSearch, ListResults]
                      , _stResults = []
                      , _stSortResults = SortNone
                      , _stDbPath = dbPath
                      , _yankCommand = Map.findWithDefault "xclip" "yank" settings
                      , _yankArgs = Map.findWithDefault "" "yankArgs" settings
                      }
          
  -- And run brick
  void $ B.customMain (V.mkVty V.defaultConfig) (Just chan) app st

  where
    -- | Get the local time
    getTime = do
      t <- Tm.getCurrentTime
      tz <- Tm.getCurrentTimeZone
      pure $ Tm.utcToLocalTime tz t


-- | Main even handler for brick events
handleEvent :: BrickState -> B.BrickEvent Name Event -> B.EventM Name (B.Next BrickState)
handleEvent st ev =
  case ev of
    -- Handle keyboard events
    --   k is the key
    --   ms are the modifier keys
    (B.VtyEvent ve@(V.EvKey k ms)) ->
      case (k, ms) of
        -- Escape quits the app, no matter what control has focus
        (K.KEsc, []) -> B.halt st

        _ ->
          -- How to interpret the key press depends on which control is focused
          case BF.focusGetCurrent $ st ^. stFocus of
            Just TypeSearch ->
              case k of
                K.KChar '\t' -> do
                  -- Search, clear sort order, focus next
                  found <- doSearch st
                  B.continue . filterResults $ st & stFocus %~ BF.focusNext
                                                  & stResults .~ found
                                                  & stSortResults .~ SortNone

                K.KBackTab ->do
                  -- Search, clear sort order, focus prev
                  found <- doSearch st
                  B.continue  . filterResults $ st & stFocus %~ BF.focusPrev
                                                   & stResults .~ found
                                                   & stSortResults .~ SortNone

                K.KEnter -> do
                  -- Search, clear sort order, focus on results
                  --  This makes it faster if you want to search and navigate results without tabing through the text search box
                  found <- doSearch st
                  B.continue . filterResults $ st & stResults .~ found
                                                  & stSortResults .~ SortNone
                                                  & stFocus %~ BF.focusNext & stFocus %~ BF.focusNext
                                                  -- TODO with brick >= 0.33, rather than 2x focus next: & stFocus %~ BF.focusSetCurrent ListResults

                _ -> do
                  -- Let the editor handle all other events
                  r <- BE.handleEditorEvent ve $ st ^. stEditType
                  next <- liftIO . searchAhead doSearch $ st & stEditType .~ r 
                  B.continue next


            Just TextSearch ->
              case k of
                K.KChar '\t' -> B.continue $ st & stFocus %~ BF.focusNext -- Focus next
                K.KBackTab -> B.continue $ st & stFocus %~ BF.focusPrev   -- Focus previous
                _ -> do
                  -- Let the editor handle all other events
                  r <- BE.handleEditorEvent ve $ st ^. stEditText
                  B.continue . filterResults $ st & stEditText .~ r

            Just ListResults ->
              case k of
                K.KChar '\t' -> B.continue $ st & stFocus %~ BF.focusNext -- Focus next
                K.KBackTab -> B.continue $ st & stFocus %~ BF.focusPrev   -- Focus previous
                K.KChar 's' ->
                  -- Toggle the search order between ascending and descending, use asc if sort order was 'none'
                  let sortDir = if (st ^. stSortResults) == SortAsc then SortDec else SortAsc in
                  let sorter = if sortDir == SortDec then (Lst.sortBy $ flip compareType) else (Lst.sortBy compareType) in
                  B.continue . filterResults $ st & stResults %~ sorter
                                                  & stSortResults .~ sortDir
                K.KChar 'p' -> do
                  let selected = BL.listSelectedElement $ st ^. stResultsList
                  B.suspendAndResume (yankPackage st selected)
                K.KChar 'm' -> do
                  let selected = BL.listSelectedElement $ st ^. stResultsList
                  B.suspendAndResume (yankModule st selected)
                _ -> do
                  -- Let the list handle all other events
                  -- Using handleListEventVi which adds vi-style keybindings for navigation
                  --  and the standard handleListEvent as a fallback for all other events
                  r <- BL.handleListEventVi BL.handleListEvent ve $ st ^. stResultsList
                  B.continue $ st & stResultsList .~ r

            _ -> B.continue st

    (B.AppEvent (EventUpdateTime time)) ->
      -- Update the time in the state
      B.continue $ st & stTime .~ time
      
    _ -> B.continue st

  where
    doSearch st' = 
      liftIO $ searchHoogle (st' ^. stDbPath) (Txt.strip . Txt.concat $ BE.getEditContents (st' ^. stEditType))


yank :: (H.Target -> Maybe Text) -> BrickState -> Maybe (Int, H.Target) -> IO BrickState
yank getText st selected = 
  case getText <<$>> selected of
    Just (_, Just s') -> do
      let cmd = (st ^. yankCommand) <> " " <> (st ^. yankArgs)
      PT.runProcess_ $ PT.setStdin (PT.byteStringInput (BSL.fromStrict . TxtE.encodeUtf8 $ s')) (PT.shell (Txt.unpack cmd))
      pure st

    _ ->
      pure st


yankPackage :: BrickState -> Maybe (Int, H.Target) -> IO BrickState
yankPackage st selected = 
  yank (\t -> Txt.pack . fst <$> H.targetPackage t) st selected


yankModule :: BrickState -> Maybe (Int, H.Target) -> IO BrickState
yankModule st selected = 
  yank (\t -> Txt.pack . fst <$> H.targetModule t) st selected


-- | Search ahead for type strings longer than 3 chars.
searchAhead :: (BrickState -> IO [H.Target]) -> BrickState -> IO BrickState
searchAhead search st =
  let searchText = Txt.strip . Txt.concat . BE.getEditContents $ st ^. stEditType in

  if Txt.length (Txt.filter (`notElem` [' ', '\t', '(', ')', '=']) searchText) > 3
  then do
    -- Search
    found <- search st
    pure . filterResults $ st & stResults .~ found
                              & stSortResults .~ SortNone
  else
    -- Just clear
    pure $ st & stResults .~ []
              & stResultsList %~ BL.listClear


-- | Filter the results from hoogle using the search text
filterResults :: BrickState -> BrickState
filterResults st =
  let allResults = st ^. stResults in
  let filterText = Txt.toLower . Txt.strip . Txt.concat . BE.getEditContents $ st ^. stEditText in

  let results =
        if Txt.null filterText
        then allResults
        else filter (\t -> Txt.isInfixOf filterText . Txt.toLower $ formatResult t) allResults
  in
  st & stResultsList .~ BL.list ListResults (Vec.fromList results) 1
  

-- | Draw the UI
drawUI :: BrickState -> [B.Widget Name]
drawUI st =
  [B.padAll 1 contentBlock] 

  where
    contentBlock =
      (B.withBorderStyle BBS.unicode $ BB.border searchBlock)
      <=>
      B.padTop (B.Pad 1) resultsBlock
      
    resultsBlock =
      let total = show . length $ st ^. stResults in
      let showing = show . length $ st ^. stResultsList ^. BL.listElementsL in
      (B.withAttr "infoTitle" $ B.txt "Results: ") <+> B.txt (showing <> "/" <> total)
      <=>
      (B.padTop (B.Pad 1) $
       resultsContent <+> resultsDetail
      )

    resultsContent =
      BL.renderList (\_ e -> B.txt $ formatResult e) False (st ^. stResultsList)

    resultsDetail =
      B.padLeft (B.Pad 1) $
      B.hLimit 60 $
      vtitle "package:"
      <=>
      B.padLeft (B.Pad 2) (B.txt $ getSelectedDetail (\t -> maybe "" (Txt.pack . fst) (H.targetPackage t)))
      <=>
      vtitle "module:"
      <=>
      B.padLeft (B.Pad 2) (B.txt $ getSelectedDetail (\t -> maybe "" (Txt.pack . fst) (H.targetModule t)))
      <=>
      vtitle "docs:"
      <=>
      B.padLeft (B.Pad 2) (B.txtWrap . reflow $ getSelectedDetail (Txt.pack . clean . H.targetDocs))
      <=>
      B.fill ' '
  
    searchBlock =
      ((htitle "Type: " <+> editor TypeSearch (st ^. stEditType)) <+> time (st ^. stTime))
      <=>
      (htitle "Text: " <+> editor TextSearch (st ^. stEditText))

    htitle t =
      B.hLimit 20 $
      B.withAttr "infoTitle" $
      B.txt t
      
    vtitle t =
      B.withAttr "infoTitle" $
      B.txt t

    editor n e =
      B.vLimit 1 $
      BE.renderEditor (B.txt . Txt.unlines) (BF.focusGetCurrent (st ^. stFocus) == Just n) e

    time t =
      B.padLeft (B.Pad 1) $
      B.hLimit 20 $
      B.withAttr "time" $
      B.str (Tm.formatTime Tm.defaultTimeLocale "%H-%M-%S" t)

    getSelectedDetail fn =
      case BL.listSelectedElement $ st ^. stResultsList of
        Nothing -> ""
        Just (_, e) -> fn e


-- | Reformat the text so that it can be wrapped nicely
reflow :: Text -> Text
reflow = Txt.replace "\n" " " . Txt.replace "\n\n" "\n" . Txt.replace "\0" "\n"


theMap :: BA.AttrMap
theMap = BA.attrMap V.defAttr [ (BE.editAttr        , V.black `B.on` V.cyan)
                              , (BE.editFocusedAttr , V.black `B.on` V.yellow)
                              , (BL.listAttr        , V.white `B.on` V.blue)
                              , (BL.listSelectedAttr, V.blue `B.on` V.white)
                              , ("infoTitle"        , B.fg V.cyan)
                              , ("time"             , B.fg V.yellow)
                              ]


getFiles :: FilePath -> IO [FilePath]
getFiles p = do
  entries <- (p </>) <<$>> (Dir.listDirectory p)
  filterM Dir.doesFileExist entries

----------------------------------------------------------------------------------------------
-- | Compare two hoogle results for sorting
compareType :: H.Target -> H.Target -> Ordering
compareType a b =
  compare (formatResult a) (formatResult b)

  
-- | Search hoogle using the default hoogle database
searchHoogle :: FilePath -> Text -> IO [H.Target]
searchHoogle path f = 
  H.withDatabase path (\x -> pure $ H.searchDatabase x (Txt.unpack f))
  

-- | Format the hoogle results so they roughly match what the terminal app would show
formatResult :: H.Target -> Text
formatResult t =
  let typ = clean $ H.targetItem t in
  let m = (clean . fst) <$> H.targetModule t in
  Txt.pack $ fromMaybe "" m <> " :: " <> typ
  

clean :: [Char] -> [Char]
clean = unescapeHTML . stripTags


-- | From hoogle source: https://hackage.haskell.org/package/hoogle-5.0.16/docs/src/General-Util.html
unescapeHTML :: [Char] -> [Char]
unescapeHTML ('&':xs)
    | Just x <- Lst.stripPrefix "lt;" xs = '<' : unescapeHTML x
    | Just x <- Lst.stripPrefix "gt;" xs = '>' : unescapeHTML x
    | Just x <- Lst.stripPrefix "amp;" xs = '&' : unescapeHTML x
    | Just x <- Lst.stripPrefix "quot;" xs = '\"' : unescapeHTML x
unescapeHTML (x:xs) = x : unescapeHTML xs
unescapeHTML [] = []
  

-- | From hakyll source: https://hackage.haskell.org/package/hakyll-4.1.2.1/docs/src/Hakyll-Web-Html.html#stripTags
stripTags :: [Char] -> [Char]
stripTags []         = []
stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
stripTags (x : xs)   = x : stripTags xs

----------------------------------------------------------------------------------------------------

loadSettings :: IO (Map Text Text)
loadSettings = do
  p <- getSettingsFilePath

  Dir.doesFileExist p >>= \case
    True -> do
      cfgLines1 <- Txt.lines . TxtE.decodeUtf8 <$> BS.readFile p
      let cfgLines2 = Txt.strip <$> cfgLines1
      let cfgLines3 = filter (not . Txt.isPrefixOf "#") cfgLines2
      let cfg1 = Txt.breakOn "=" <$> cfgLines3
      let cfg2 = filter (not . Txt.null . snd) cfg1
      let cfg3 = (\(k, v) -> (Txt.strip k, Txt.strip . Txt.drop 1 $ v)) <$> cfg2
      pure $ Map.fromList cfg3
    False ->
      pure Map.empty

saveSettings :: Map Text Text -> IO ()
saveSettings settings = do
  p <- getSettingsFilePath
  let ss = Txt.intercalate "\n" $ (\(k, v) -> k <> "=" <> v) <$> Map.toList settings
  BS.writeFile p . TxtE.encodeUtf8 $ ss


getSettingsFilePath :: IO FilePath
getSettingsFilePath = do
  p <- getSettingsRootPath
  pure $ p </> "bhoogle.conf"


getSettingsRootPath :: IO FilePath
getSettingsRootPath = do
  p <- Dir.getXdgDirectory Dir.XdgConfig "bhoogle"
  Dir.createDirectoryIfMissing True p
  pure p