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, Eq)

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
  , hwBuiltIns              :: Map.Map Text Text
  }

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 (hwBuiltIns w) 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 False False False Esc    -> do
        case hwHistory w of
          [] -> liftIO $ atomically $ writeTChan (hwIdeEventsChan w) IDEToggleHelp
          ((p, o) :rst) -> do
            modifyWRef r (\hw -> hw { hwHistory = rst })
            loadPage' p o
      -- In the matches below don't insist that shift is not pressed
      -- so that shift+arrow key selections are possible.
      KeyCtrl False _ False ArrowUp    -> handleInput (hwContentWidget w) ke
      KeyCtrl False _ False ArrowDown  -> handleInput (hwContentWidget w) ke
      KeyCtrl False _ False ArrowRight -> handleInput (hwContentWidget w) ke
      KeyCtrl False _ False ArrowLeft  -> handleInput (hwContentWidget w) ke
      KeyCtrl False _ False PageUp     -> handleInput (hwContentWidget w) ke
      KeyCtrl False _ False PageDown   -> handleInput (hwContentWidget w) ke
      KeyCtrl False False False Return     -> do
        tokens <- liftIO $ readIORef (hwTokensRef w)
        case V.find (\case
          -- True in the first field signifies cursor is over this link
          DisplayToken (DTLink True _) _ _ -> True
          _                                -> False) tokens of
            Just (DisplayToken (DTLink _ n) _ _) -> do
              case Map.lookup n (hwContentIndex w) of
                Just (page, idx) -> do
                  pushCurrentPageToHistory
                  loadPage' (Right page) idx
                Nothing -> pure ()
            _ -> pure ()
      _                        -> do
        if hasKeyCombination ke
          -- This check prevents unintendend, redundant firing of search.
          -- which was causing a loaded page to immediately replaced by
          -- the search results that precedded the loading of this page.
          then pass
          else do
            handleInput (hwSearchWidget w) ke
            swr <- readWRef (hwSearchWidget w)
            let newPage = Left $ SearchPage $ ewContent swr
            loadPage' newPage 0

    ew <- readWRef (hwContentWidget w)
    void $ liftIO $ tryPutMVar (hwCursorRef w) (ewCursor ew)
    where
      hasKeyCombination (KeyCtrl False False False _) = False
      hasKeyCombination (KeyChar False False False _) = False
      hasKeyCombination _                             = True

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 -> (resetCursor ew) { ewContent = contentText, ewShowVirtualCursor = True })
  liftIO $ atomically $ writeTChan ideEventRef IDEClearDraw

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 IDEClearDraw
  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 :: Map.Map Text Text -> IO (Map.Map FilePath (Text, V.Vector DisplayToken))
parsedDocContent builtIns = 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 builtIns (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 => Map.Map Text Text -> TChan IDEEvent -> m (WRef HelpWidget)
helpWidget builtinsFull ideEventRef = do
    let builtins = (Prelude.head . T.split (== '.')) <$> (Map.keys builtinsFull)
    -- The help window
    let helpWidgetDimDistrbution = [
          undefined
          , [1]
          , [0, 1]
          ]
    let helpWidgetTopDimDistrbution =
          [ undefined
          , undefined
          , [0.1, 0.9]
          ]
    cursorRef <- liftIO $ newMVar @Int 0
    searchResultRef <- liftIO newEmptyMVar
    searchChan <- liftIO (newTChanIO @SearchPage)
    helpLayoutRef <- layoutWidget Vertical helpWidgetDimDistrbution
    helptopLayoutRef <- layoutWidget Horizontal helpWidgetTopDimDistrbution
    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) { epBorder = True, epGutterSize = 0, epLineNos = False} })
    modifyWRef helpContent (\hw -> hw { ewShowVirtualCursor = True, ewParams = (ewParams hw) { epLineNos = False} })
    addWidget helptopLayoutRef helpSearchInput
    (newWRef nullWidget) >>= addWidget helptopLayoutRef
    addWidget helpLayoutRef helptopLayoutRef
    addWidget helpLayoutRef helpContent
    docs <- liftIO $ parsedDocContent builtinsFull
    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 (T.dropWhileEnd (\c -> c == '(' || c == ')') <$> 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 builtinsFull
            loadPage r (Right "toc.md")
            pure r