Draw.hs

module Editor.Draw where

import Brick
import qualified Brick.Widgets.Border as Border
import Control.Monad ((<=<))
import Data.List (find, groupBy)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Zipper as Z
import Editor.Core
import Editor.Diagnostic
import Editor.Selection
import Editor.Util
import Lens.Micro
import UI.Attributes
import UI.Core
import Zwirn.Language.Lexer (Lexeme, Token (..), tokenise)
import Zwirn.Language.Location (Located (..), RealSrcLoc (..), SrcLoc (..))

drawEditor :: Bool -> (Name, (Int, Int), EditorState) -> Widget Name
drawEditor active (name, size, es) =
  vBox
    [ drawEditorBody active name size es,
      vLimit 1 $ drawStatusBar es
    ]

drawStatusBar :: EditorState -> Widget Name
drawStatusBar es =
  let filePart = fromMaybe "[No Name]" (es ^. esFilePath)
      unsaved = if es ^. esUnsaved then "*" else " "
      cursor = Z.cursorPosition $ es ^. esZipper
      pos =
        "Ln "
          ++ show (fst cursor + 1)
          ++ ", Col "
          ++ show (snd cursor + 1)
      msg = fromMaybe "" (es ^. esMessage)
      left = " " ++ unsaved ++ " " ++ filePart ++ "  " ++ msg
      right = pos ++ " "
   in withAttr attrStatusBar $
        hBox
          [ str left,
            fill ' ',
            str right
          ]

drawPopup :: Maybe Popup -> Widget Name
drawPopup Nothing = emptyWidget
drawPopup (Just (Popup content (col, row))) = translateBy (Location (col + 1, row + 1)) $ Border.border $ str content

drawEditorBody :: Bool -> Name -> (Int, Int) -> EditorState -> Widget Name
drawEditorBody active name (sx, sy) es = hBox [lineNumbers, viewport (fromName name) Both $ visibleRegion (Location (c, r)) (1, 1) $ cursor $ vLimit (max cy sy) $ hLimit (max cx sx) $ vBox (rowWidgets ++ bottomPadding)]
  where
    fromName (Editor i) = EditorViewport i
    fromName x = x
    cy = lineCount es
    cx = getLongestLine es

    ds = es ^. esDiagnostics
    flashed i = case es ^. esFlashBlock of
      Nothing -> Nothing
      Just (ty, (st, en)) -> if st <= i && i <= en then Just ty else Nothing
    (r, c) = currentCursor es

    maxLineWidth = lineNumberWidth es
    allLines = getLines es

    indexedRows = zipWith (\ro l -> (ro, l, rowDiagnostics ro ds, flashed ro)) [0 ..] allLines
    lineNumbers = vBox $ map (drawLineNumber (fromName name) r maxLineWidth) [0 .. length allLines - 1]

    rowWidgets = map (drawRow es) indexedRows

    remainingRows = max 0 (sy - cy)
    bottomPadding = replicate remainingRows (fill ' ')
    cursor = if active then showCursor Cursor (Location (c, r)) else id

drawRow :: EditorState -> (Int, Text, [Diagnostic], Maybe OutputType) -> Widget Name
drawRow es (row, rawLine, ds, flashed) =
  let cursor = currentCursor es
      isCurRow = fst cursor == row
      tokens = tokenizeLine (es ^. esSelection) cursor row ds rawLine
      lineWidget = hBox [renderTokens tokens, fill ' ']
      rowWidget = lineWidget
   in case flashed of
        Just OutputInfo -> withDefAttr attrFlash rowWidget
        Just OutputError -> withDefAttr attrFlashError rowWidget
        _ ->
          if isCurRow
            then withDefAttr attrCurrentLine rowWidget
            else rowWidget

cellAttr :: Maybe (Int, Int) -> (Int, Int) -> Int -> Int -> [Diagnostic] -> Maybe AttrName -> Maybe AttrName
cellAttr Nothing _ row col ds@(_ : _) x = if inAnyDiagnostic (row, col) ds then Just attrError else x
cellAttr Nothing _ _ _ _ x = x
cellAttr (Just sel) cursor row col ds matt
  | insel && inerr = Just $ attrSelected <> attrError
  | insel = maybe (Just attrSelected) (\att -> Just $ attrSelected <> att) matt
  | inerr = Just attrError
  | otherwise = matt
  where
    insel = inSelection (row, col) cursor (Just sel)
    inerr = inAnyDiagnostic (row, col) ds

tokenizeLine :: Maybe (Int, Int) -> (Int, Int) -> Int -> [Diagnostic] -> Text -> [(Maybe AttrName, Text)]
tokenizeLine mSel cursor row ds text =
  concatMap toToken $
    groupBy sameAttr $
      zipWith (\col ch -> (cellAttr mSel cursor row col ds (inLexeme col ls), ch)) [0 ..] (T.unpack text)
  where
    toToken [] = []
    toToken ((a, x) : pairs) = [(a, T.pack $ x : map snd pairs)]
    sameAttr (a, _) (b, _) = a == b
    ls = getLexemes text

renderTokens :: [(Maybe AttrName, Text)] -> Widget Name
renderTokens ts = hBox [maybe (txt s) (\a -> withAttr a (txt s)) attr | (attr, s) <- ts]

drawLineNumber :: Name -> Int -> Int -> Int -> Widget Name
drawLineNumber vpn currentRow maxWidth row = Widget Fixed Fixed $ do
  vp <- unsafeLookupViewport vpn
  let ro = maybe 0 (\(VP _ x _ _) -> x) vp
      line = show (row + ro + 1) ++ " "
      padding = maxWidth - length line
      attr = if currentRow == row + ro then withAttr attrCurrentLineNum else withAttr attrLineNum
  render $ attr $ padLeft (Pad padding) $ str line

getLexemes :: Text -> [Lexeme]
getLexemes t = case tokenise t of
  Left _ -> []
  Right ls -> ls

inLexeme :: Int -> [Lexeme] -> Maybe AttrName
inLexeme i = strip <=< find (\(Located p _) -> contained p)
  where
    contained (SrcLoc (RealSrcLoc _ _ sc _ ec)) = sc - 1 <= i && i < ec - 1
    contained _ = False
    strip (Located _ x) = tokenToAttribute x

tokenToAttribute :: Token -> Maybe AttrName
tokenToAttribute (TextTok _) = Just syntaxText
tokenToAttribute (NumberTok _) = Just syntaxNumber
tokenToAttribute (OperatorTok _) = Just syntaxOperator
tokenToAttribute (SpecialOperatorTok _) = Just syntaxOperator
tokenToAttribute RestTok = Just syntaxSilence
tokenToAttribute IfTok = Just syntaxKeyword
tokenToAttribute ThenTok = Just syntaxKeyword
tokenToAttribute ElseTok = Just syntaxKeyword
tokenToAttribute LambdaTok = Just syntaxKeyword
tokenToAttribute ArrowTok = Just syntaxKeyword
tokenToAttribute DefineTok = Just syntaxKeyword
tokenToAttribute DynamicDefineTok = Just syntaxKeyword
tokenToAttribute TypeCommandTok = Just syntaxKeyword
tokenToAttribute ShowCommandTok = Just syntaxKeyword
tokenToAttribute InfoCommandTok = Just syntaxKeyword
tokenToAttribute ResetShowConfigCommandTok = Just syntaxKeyword
tokenToAttribute ResetEnvCommandTok = Just syntaxKeyword
tokenToAttribute SetCommandTok = Just syntaxKeyword
tokenToAttribute StatusCommandTok = Just syntaxKeyword
tokenToAttribute EnvCommandTok = Just syntaxKeyword
tokenToAttribute (LoadCommandTok _) = Just syntaxKeyword
tokenToAttribute _ = Nothing