Help.hs

module IDE.Help where

import Compiler.Lexer.Keywords (Keyword)
import Compiler.Lexer.Operators (Operator)
import Control.Concurrent
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TChan
import Control.Monad as CM
import qualified Data.ByteString as BS
import Data.IORef
import qualified Data.List as DL
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Vector as V

import Common
import Compiler.AST.Program
import Compiler.Parser
import IDE.Common
import IDE.Help.Contents
import IDE.Help.Parser
import UI.Widgets
import UI.Widgets.Layout
import UI.Widgets.NullWidget

newtype SearchPage = SearchPage Text
  deriving Show

type HelpPage = Either SearchPage FilePath

data HelpWidget = HelpWidget
  { hwSearchWidget          :: WRef EditorWidget
  , hwContentWidget         :: WRef EditorWidget
  , hwMainLayout            :: WRef LayoutWidget
  , hwVisible               :: Bool
  , hwCursorRef             :: MVar Int
  , hwTokenProcessingThread :: Maybe ThreadId
  , hwIdeEventsChan         :: TChan IDEEvent
  , hwTokensRef             :: IORef (V.Vector DisplayToken)
  , hwContent               :: Map.Map FilePath (Text, V.Vector DisplayToken)
  , hwContentIndex          :: Map.Map Text (FilePath, Int)
  , hwCurrentPage           :: Maybe HelpPage
  , hwHistory               :: [(HelpPage, Int)]
  , hwSearchResult          :: MVar (SearchPage, V.Vector HToken)
  , hwSearchChan            :: TChan SearchPage
  }

instance Drawable HelpWidget where
  draw r = do
    w <- readWRef r
    case hwVisible w of
      True -> do
        (liftIO $ tryTakeMVar (hwSearchResult w)) >>= \case
          Just (sp, htokens) -> do
            let (contentText, dTokens) = convertToDisplay htokens
            loadTokens r (contentText, dTokens)
            modifyWRef r (\wd -> wd { hwCurrentPage = Just (Left sp) })
          Nothing -> pass
        draw $ hwMainLayout w
      _    -> pass
  setVisibility r v = do
    modifyWRef r (\hw -> hw { hwVisible = v })
  getVisibility r =
    hwVisible <$> readWRef r

instance KeyInput HelpWidget where
  getCursorInfo r = do
    w <- readWRef r
    getCursorInfo $ hwSearchWidget w
  handleInput :: forall m. WidgetC m => WRef HelpWidget -> KeyEvent -> m ()
  handleInput r ke = do
    w <- readWRef r
    let
      pushCurrentPageToHistory :: m ()
      pushCurrentPageToHistory = do
        case hwCurrentPage w of
          Just p -> do
            cw <- readWRef (hwContentWidget w)
            let currentOffset = ewCursor cw
            modifyWRef r (\hw ->
              hw { hwHistory = (p, currentOffset) : hwHistory hw }
              )
          Nothing -> pure ()

      loadPage' :: HelpPage -> Int -> m ()
      loadPage' page idx  = do
        loadPage r page
        modifyWRef (hwContentWidget w) (\x -> let
          newEw = putCursor Nothing idx x
          newSo = computeScrollOffset newEw (fst $ ewCursorInfo newEw)
          in newEw { ewScrollOffset = if newSo /= ewScrollOffset x then newSo + (div (diH $ ewDim newEw) 2) else newSo }
          )
    case ke of
      KeyCtrl _ _ _ Esc    -> do
        case hwHistory w of
          [] -> pure ()
          ((p, o) :rst) -> do
            modifyWRef r (\hw -> hw { hwHistory = rst })
            loadPage' p o
      KeyCtrl _ _ _ ArrowUp    -> handleInput (hwContentWidget w) ke
      KeyCtrl _ _ _ ArrowDown  -> handleInput (hwContentWidget w) ke
      KeyCtrl _ _ _ ArrowRight -> handleInput (hwContentWidget w) ke
      KeyCtrl _ _ _ ArrowLeft  -> handleInput (hwContentWidget w) ke
      KeyCtrl _ _ _ Return     -> do
        tokens <- liftIO $ readIORef (hwTokensRef w)
        case V.find (\case
          DisplayToken (DTLink True _) _ _ -> True
          _                                -> False) tokens of
            Just (DisplayToken (DTLink _ n) _ _) -> case Map.lookup n (hwContentIndex w) of
              Just (page, idx) -> do
                pushCurrentPageToHistory
                loadPage' (Right page) idx
              Nothing -> pure ()
            _ -> pure ()
      _                        -> do
        handleInput (hwSearchWidget w) ke
        swr <- readWRef (hwSearchWidget w)
        loadPage' (Left (SearchPage $ ewContent swr)) 0

    ew <- readWRef (hwContentWidget w)
    void $ liftIO $ tryPutMVar (hwCursorRef w) (ewCursor ew)

instance Moveable HelpWidget where
  move r pos = do
    w <- hwMainLayout <$> readWRef r
    move w pos
  getPos r = do
    w <- hwMainLayout <$> readWRef r
    getPos w
  getDim r = do
    w <- hwMainLayout <$> readWRef r
    getDim w
  resize r fn = do
    w <- hwMainLayout <$> readWRef r
    resize w fn

instance Widget HelpWidget where
  hasCapability (DrawableCap _) = Just Dict
  hasCapability (KeyInputCap _) = Just Dict
  hasCapability (MoveableCap _) = Just Dict
  hasCapability _               = Nothing

searchThread
  :: Map.Map Text (FilePath, Int)
  -> TChan SearchPage
  -> MVar (SearchPage, V.Vector HToken)
  -> IO ()
searchThread contentIndex spChan resultRef = do
  let indexKeys = Map.keys contentIndex
  forever $ do
    SearchPage (T.toLower -> skey) <- atomically $ readTChan spChan
    let results = DL.foldl' (foldFn skey) [] indexKeys
    putMVar resultRef (SearchPage skey, V.fromList (mkHToken <$> results))
  where
    mkHToken x = HToken x emptyLocation 0
    foldFn :: Text -> [HTokenRaw] -> Text -> [HTokenRaw]
    foldFn k rs hd = if k `T.isInfixOf` (T.toLower hd) then (Link hd : NewLine : rs) else rs

loadPage
  :: WidgetC m
  => WRef HelpWidget
  -> HelpPage
  -> m ()
loadPage ref page' = do
  HelpWidget { hwContent = map' } <- readWRef ref
  case page' of
    Right page -> case Map.lookup page map' of
      Nothing -> pure ()
      Just (contentText, dtTokens) -> do
        loadTokens ref (contentText, dtTokens)
        modifyWRef ref (\hw -> hw { hwCurrentPage = Just page' })
    Left (SearchPage "") -> loadPage ref (Right "toc.md")
    Left sk -> do
      w <- readWRef ref
      liftIO $ atomically $ writeTChan (hwSearchChan w) sk

loadTokens
  :: WidgetC m
  => WRef HelpWidget
  -> (Text, V.Vector DisplayToken)
  -> m ()
loadTokens helpWidgetRef (contentText, dtTokens) = do
  HelpWidget { hwIdeEventsChan = ideEventRef, hwContentWidget = ewRef, hwTokensRef = tokensRef} <- readWRef helpWidgetRef
  liftIO $ writeIORef tokensRef dtTokens
  modifyWRef ewRef (\ew -> ew { ewScrollOffset = 0, ewContent = contentText, ewShowVirtualCursor = True })
  liftIO $ atomically $ writeTChan ideEventRef IDEDraw

collectLinks
  :: Map.Map FilePath (Text, V.Vector DisplayToken)
  -> [Text]
collectLinks docs = Map.foldrWithKey mapFoldFn mempty docs
  where
    mapFoldFn
      :: FilePath
      -> (Text, V.Vector DisplayToken)
      -> [Text]
      -> [Text]
    mapFoldFn fp (_, tkns) idx = V.foldl' (foldFn fp) idx tkns

    foldFn
      :: FilePath
      -> [Text]
      -> DisplayToken
      -> [Text]
    foldFn _ idx (DisplayToken (DTLink _ t) _ _) = t : idx
    foldFn _ idx _                               = idx

buildIndex
  :: Map.Map FilePath (Text, V.Vector DisplayToken)
  -> Map.Map Text (FilePath, Int)
buildIndex docs = Map.foldrWithKey mapFoldFn mempty docs
  where
    mapFoldFn
      :: FilePath
      -> (Text, V.Vector DisplayToken)
      -> Map.Map Text (FilePath, Int)
      -> Map.Map Text (FilePath, Int)
    mapFoldFn fp (_, tkns) idx = V.foldl' (foldFn fp) idx tkns

    foldFn
      :: FilePath
      -> Map.Map Text (FilePath, Int)
      -> DisplayToken
      -> Map.Map Text (FilePath, Int)
    foldFn fp idx (DisplayToken (DTHeading _ t) l _) = Map.insert t (fp, lcOffset l) idx
    foldFn _ idx _ = idx

tokenProcessing :: TChan IDEEvent -> MVar Int -> IORef (V.Vector DisplayToken) -> IO ()
tokenProcessing ideEventRef cursorRef tokensRef = forever $ do
  cursor <- takeMVar cursorRef
  modifyIORef tokensRef (V.map (mapFn cursor))
  liftIO $ atomically $ writeTChan ideEventRef IDEDraw
  where
    mapFn :: Int -> DisplayToken -> DisplayToken
    mapFn cursor dt = if cursor >= (lcOffset $ dtLocation dt) && cursor <= (dtOffsetEnd dt)
      then case dt of
        DisplayToken (DTLink _ n) l e -> DisplayToken (DTLink True n) l e
        _                             -> dt
      else case dt of
        DisplayToken (DTLink _ n) l e -> DisplayToken (DTLink False n) l e
        _                             -> dt

parsedDocContent :: IO (Map.Map FilePath (Text, V.Vector DisplayToken))
parsedDocContent = UI.Widgets.foldM foldFn mempty docContent
  where
    foldFn
      :: Map.Map FilePath (Text, V.Vector DisplayToken)
      -> (FilePath, BS.ByteString)
      -> IO (Map.Map FilePath (Text, V.Vector DisplayToken))
    foldFn idx (fp,sbs) = do
      parseHelp (decodeUtf8 sbs) >>= \case
        Right tokens -> do
          checkSamples fp tokens
          pure $ Map.insert fp (convertToDisplay (V.fromList tokens)) idx
        Left err -> do
          putStrLn err
          error $ "Error while parsing help file: " <> fp

checkSamples :: FilePath -> [HToken] -> IO ()
checkSamples fp = CM.mapM_ checkOneSample . fmap tkRaw
  where
    checkOneSample :: HTokenRaw -> IO ()
    checkOneSample (Code _ tks) = parseEither @Program tks >>= \case
      Right _  -> pure ()
      Left err -> do
        error ("Error parsing code in help file:"<> fp <> ":" <> show err)
    checkOneSample _ = pure ()

helpWidget :: WidgetC m => [Text] -> TChan IDEEvent -> m (WRef HelpWidget)
helpWidget builtins ideEventRef = do
    -- The help window
    let helpWidgetDimDistrbution = \case
          1 -> [1]
          2 -> [0, 1]
          _ -> error "Unsupported widget count"
    let helpWidgetTopDimDistrbution = \case
          2 -> [0.1, 0.9]
          _ -> error "Unsupported widget count"
    cursorRef <- liftIO $ newMVar @Int 0
    searchResultRef <- liftIO newEmptyMVar
    searchChan <- liftIO (newTChanIO @SearchPage)
    helpLayoutRef <- layoutWidget Vertical helpWidgetDimDistrbution Nothing
    helptopLayoutRef <- layoutWidget Horizontal helpWidgetTopDimDistrbution Nothing
    helpSearchInput <- editor (\_ -> pure []) Nothing

    tokensRef <- liftIO $ newIORef @(V.Vector DisplayToken) V.empty

    tokenProcessingThreadId <- liftIO $ forkIO (tokenProcessing ideEventRef cursorRef tokensRef)

    helpContent <- editor (\_ -> pure []) (Just $ SomeTokenStream (V.toList <$> readIORef tokensRef))
    modifyWRef helpSearchInput (\hw -> hw { ewParams = (ewParams hw) { epLineNos = False} })
    modifyWRef helpContent (\hw -> hw { ewShowVirtualCursor = True, ewParams = (ewParams hw) { epLineNos = False} })
    addWidget helptopLayoutRef "helpsearchinput" helpSearchInput
    (newWRef nullWidget) >>= addWidget helptopLayoutRef "helpsearchspacer"
    addWidget helpLayoutRef "helpsearch" helptopLayoutRef
    addWidget helpLayoutRef "helpcontent" helpContent
    docs <- liftIO parsedDocContent
    let docIndex = buildIndex docs
    void $ liftIO $ forkIO (searchThread docIndex searchChan searchResultRef)
    let builtinOperators = "=" : ((\x -> toSource $ toEnum @Operator x) <$> [0 .. fromEnum $ maxBound @Operator])
    let builtinKeywords = (\x -> toSource $ toEnum @Keyword x) <$> [0 .. fromEnum $ maxBound @Keyword]
    let linksInDocs = Set.fromList $ collectLinks docs
    let linksInIndex = Set.fromList $ Map.keys docIndex
    let builtinSymbols = Set.fromList builtins
    let missingLinks = Set.difference linksInDocs linksInIndex
    let missingDocs = Set.difference (Set.difference builtinSymbols (Set.fromList (builtinKeywords <> builtinOperators))) linksInIndex
    if (Set.size(missingLinks) > 0)
      then error $ "Missing links in document: " <> show missingLinks
      else do
        if (Set.size(missingDocs) > 0)
          then error $ "Missing documents for: " <> show missingDocs
          else do
            r <- newWRef $ HelpWidget helpSearchInput helpContent helpLayoutRef True cursorRef (Just tokenProcessingThreadId) ideEventRef tokensRef docs docIndex Nothing [] searchResultRef searchChan
            loadPage r (Right "toc.md")
            pure r