module UI.Widgets.Editor where import Control.Monad.Loops (iterateUntilM) import Data.List as DL hiding (lines) import Data.Maybe import Data.Proxy (Proxy(..)) import Data.Text as T import Prelude hiding (lines) import System.Console.ANSI (Color(..)) import Text.Printf import Common import Highlighter.Highlighter import UI.Widgets.Common import UI.Widgets.Editor.Cursor data EditorMode = InsertMode | ReplaceMode deriving (Eq, Show) data SomeTokenStream where SomeTokenStream :: (Show a, Highlightable a) => IO [a] -> SomeTokenStream data EditorWidget = EditorWidget { ewContent :: Text , ewDim :: Dimensions , ewVisibility :: Bool , ewPos :: ScreenPos , ewCursor :: Int -- Cursor position offset into content. Starts at 0 , ewDebugLocation :: Maybe Location , ewParseErrorLocation :: Maybe Location , ewWordWrap :: Bool , eweHasFocus :: Bool , ewScrollOffset :: Int , ewInsertMode :: EditorMode , ewTokenStream :: Maybe SomeTokenStream , ewAutocompleteWidget :: Maybe SomeWidgetRef , ewAutocompleteSuggestions :: (forall m. MonadIO m => Text -> m [(Text, Text)]) , ewReadOnly :: Bool , ewCursorInfo :: CursorInfo -- Cursor info (location relative to the begining of text) , ewSelection :: Maybe (Int, Int) , ewShowVirtualCursor :: Bool , ewParams :: EditorParams , ewCursorLine :: Int -- Line on which the cursor is currently. 1 based } data EditorParams = EditorParams { epGutterSize :: Int , epLinenumberWidth :: Int , epLinenumberRightPad :: Int , epBorder :: Bool , epLineNos :: Bool } deriving Show defaultEp :: EditorParams defaultEp = EditorParams 1 4 0 True True instance Moveable EditorWidget where getPos ref = ewPos <$> readWRef ref move ref pos = modifyWRef ref (\ew -> ew { ewPos = pos }) getDim ref = ewDim <$> readWRef ref resize ref cb = modifyWRef ref (\low -> low { ewDim = cb $ ewDim low }) instance Widget EditorWidget where hasCapability (KeyInputCap _) = Just Dict hasCapability (DrawableCap _) = Just Dict hasCapability (MoveableCap _) = Just Dict hasCapability _ = Nothing getTextPaddingAndSoftLineLength :: Dimensions -> EditorParams -> (Int, Int) getTextPaddingAndSoftLineLength d EditorParams {..} = let linenumberWidth' = if epLineNos then epLinenumberWidth else 0 linenumberRightPad' = if epLineNos then epLinenumberRightPad else 0 epBorderSize = if epBorder then 1 else 0 textPadding = epBorderSize + epGutterSize + linenumberWidth' + linenumberRightPad' softLineLength = (diW d) - textPadding - epBorderSize in (textPadding, softLineLength) getContentStart :: EditorParams -> ScreenPos getContentStart EditorParams {..} = let epBorderSize = if epBorder then 1 else 0 in ScreenPos (epBorderSize + epGutterSize) epBorderSize getTextContentStart :: Dimensions -> EditorParams -> ScreenPos getTextContentStart d ep = let (tp, _) = getTextPaddingAndSoftLineLength d ep in addSp (ScreenPos (tp - 1) 0) (getContentStart ep) resetCursor :: EditorWidget -> EditorWidget resetCursor ew = ew { ewScrollOffset = 0, ewCursor = 0, ewCursorInfo = (ScreenPos 0 0, Bar) } wrapInSpace :: Text -> Text wrapInSpace x = " " <> x <> " " instance Drawable EditorWidget where setVisibility ref v = modifyWRefM ref (\b -> do case ewAutocompleteWidget b of Just (SomeWidgetRef acRef) -> withCapability (DrawableCap acRef) $ do setVisibility acRef False _ -> pure () pure $ b { ewVisibility = v }) getVisibility ref = ewVisibility <$> readWRef ref draw ref = do w <- readWRef ref draw' w where draw' w = do let epBorderSize = if (epBorder $ ewParams w) then 1 else 0 if ((diH $ ewDim w) > 2 && (epBorder $ ewParams w)) then drawBorderBox (ewPos w) (ewDim w) else pass let (_, softLineLength) = getTextPaddingAndSoftLineLength (ewDim w) params let content = ewContent w let cursorLine = ewCursorLine w let contentHeight = (diH $ ewDim w) - (2 * epBorderSize) let mDlocation = ewDebugLocation w let mElocation = ewParseErrorLocation w let mSelection = ewSelection w let mCursorLoc = if (ewShowVirtualCursor w) then Just (ewCursor w) else Nothing let contentStartPos = addSp (getContentStart params) (ewPos w) case ewTokenStream w of Nothing -> void $ iterateUntilM isNothing (printOneLine @Text params mCursorLoc (epLineNos params) cursorLine mSelection mElocation mDlocation (softLineLength, contentHeight) (ewScrollOffset w) contentStartPos) $ Just (content, 1, 0, 0, []) Just (SomeTokenStream (readTokens :: IO [tokenstream])) -> do tokens <- liftIO readTokens void $ iterateUntilM isNothing (printOneLine @tokenstream params mCursorLoc (epLineNos params) cursorLine mSelection mElocation mDlocation (softLineLength, contentHeight) (ewScrollOffset w) contentStartPos) $ Just (content, 1, 0, 0, tokens) getCursorInfo ref >>= \case Nothing -> pure () Just (cl, _) -> do case (ewAutocompleteWidget w) of Just (SomeWidgetRef a) -> withCapability (DrawableCap a) $ do getVisibility a >>= \case False -> pure () True -> do withCapability (MoveableCap a) $ do Dimensions bx by <- getScreenBounds Dimensions ax ay <- getDim a let newAcPos = moveDown 1 cl acEndY = sY $ moveDown ay newAcPos acEndX = sX $ moveRight ax newAcPos rightOf = acEndX - bx bottomOf = acEndY - by bottomOfFixed = if bottomOf > 0 then moveUp (ay+1) newAcPos else newAcPos rightOfFixed = if rightOf > 0 then moveLeft rightOf bottomOfFixed else bottomOfFixed move a rightOfFixed Nothing -> pure () where params = ewParams w printOneLine :: forall a m. (Show a, WidgetC m, Highlightable a) => EditorParams -> Maybe Int -> Bool -> Int -> Maybe (Int, Int) -> Maybe Location -> Maybe Location -> (Int, Int) -> Int -> ScreenPos -> Maybe (Text, Int, Int, Int, [a]) -> m (Maybe (Text, Int, Int, Int, [a])) printOneLine _ _ _ _ _ _ _ _ _ _ Nothing = pure Nothing printOneLine params@(EditorParams {..}) mCursorLoc showLineNos cursorLine selection errorLocation debugLocation (width, height) scrollOffset startPos (Just (cnt, lnNo, realoffset, hoffset, tokenStack)) = do -- Take until next newline let hl = T.takeWhile (/= '\n') cnt let offset = realoffset - scrollOffset case debugLocation of Just dLocation -> do when (lnNo == lcLine dLocation && ((lnNo - scrollOffset) < height) && ((lnNo - scrollOffset) > 0)) $ do wSetCursor $ moveLeft 1 $ moveDown offset startPos csPutText (colorTextFg Green ">") Nothing -> pure () case errorLocation of Just eLocation -> do when (lnNo == lcLine eLocation && ((lnNo - scrollOffset) < height) && ((lnNo - scrollOffset) > 0)) $ do wSetCursor $ moveLeft 1 $ moveDown offset startPos csPutText (colorText White Red "X") Nothing -> pure () wSetCursor $ moveDown offset startPos when (showLineNos && isPrintableArea offset height) $ do let formatstr = "%" <> show linenumberWidth' <> "d" if lnNo == cursorLine then csPutText $ colorText White Black $ pack $ printf formatstr lnNo else csPutText $ Plain $ pack $ printf formatstr lnNo let ct = T.chunksOf width hl newTokenStack <- foldM (\stk x -> printOneSoftLine params startPos debugLocation selection errorLocation mCursorLoc width height hoffset offset stk x) tokenStack $ DL.zip [0..] ct let thisLen = (T.length hl) let remaining = T.drop thisLen cnt let nextOffset = hoffset + thisLen -- Process the new line in stream as well. case T.uncons remaining of Just ('\n', remaining') -> do let (_, newTokenStack') = pairWithTokens @a newTokenStack nextOffset "\n" pure $ Just (remaining', lnNo + 1, realoffset + (max 1 (DL.length ct)), nextOffset+1, newTokenStack') Just _ -> do pure $ Just (remaining, lnNo + 1, realoffset + (max 1 (DL.length ct)), nextOffset, newTokenStack) Nothing -> pure Nothing where linenumberWidth' = if showLineNos then epLinenumberWidth else 0 printOneSoftLine :: forall a m . (Highlightable a, WidgetC m) => EditorParams -> ScreenPos -> Maybe Location -> Maybe (Int, Int) -> Maybe Location -> Maybe Int -> Int -> Int -> Int -> Int -- The screen position y co-ordinate where the main, real line starts -> [a] -- The token stack at this point -> (Int, Text) -- The offset of this soft line, and the content -> m [a] -- The token stack after printing this soft line printOneSoftLine EditorParams {..} startPos debugLocation selection errorLocation mCursorLoc width height hoffset startLine tokenStack' (sfOffset, softLine) = do let startOffset = hoffset + (sfOffset * width) let realoffset' = startLine + sfOffset let (hlText, tokenStack'') = pairWithTokens @a tokenStack' startOffset softLine if (isPrintableArea realoffset' height) then do wSetCursor $ moveRight (linenumberWidth' + linenumberRightPad') $ moveDown realoffset' startPos hlText' <- case debugLocation of Just dLocation -> do pure $ (debugColor dLocation) <$> hlText Nothing -> pure ((\(a, b) -> (Plain a, b)) <$> hlText) hlText'' <- case selection of Just sLocation -> do pure $ snd $ DL.foldl' (selectionColor sLocation) (startOffset, []) hlText' Nothing -> pure hlText' hlText''' <- case errorLocation of Just dLocation -> do pure $ (errorColor dLocation) <$> hlText'' Nothing -> pure hlText'' hlText'''' <- case mCursorLoc of Just off -> do pure $ (markVirtualCursor startOffset off) <$> hlText''' Nothing -> pure hlText''' csPutText $ StyledText NoStyle ((highlight @a) <$> hlText'''') else pure () pure tokenStack'' where linenumberWidth = epLinenumberWidth linenumberRightPad = epLinenumberRightPad linenumberWidth' = if epLineNos then linenumberWidth else 0 linenumberRightPad' = if epLineNos then linenumberRightPad else 0 debugColor _ (src, Nothing) = (Plain src, Nothing) debugColor debugLoc (src, Just token) = let tokenLoc = getTokenLoc token in if tokenLoc == debugLoc then (StyledText TextUnderline [Plain src], Just token) else (Plain src, Just token) selectionColor :: (Int, Int) -> (Int, [(StyledText, Maybe a)]) -> (StyledText, Maybe a) -> (Int, [(StyledText, Maybe a)]) selectionColor selectionLoc (startOffset, result) (src, a) = let newSrc = StyledText NoStyle (applyStyleToRange (\st -> StyledText (FgBg Black White) [st]) startOffset selectionLoc [src]) in (startOffset + stTotalLength [src], result <> [(newSrc, a)]) errorColor _ (src, Nothing) = (src, Nothing) errorColor errorLoc (src, Just token) = let tokenLoc = getTokenLoc token in if tokenLoc == errorLoc then (StyledText TextUnderline [src], Just token) else (src, Just token) markVirtualCursor :: Int -> Int -> (StyledText, Maybe a) -> (StyledText, Maybe a) markVirtualCursor startOffset cursorLoc (src, Nothing) = let newSrc = StyledText NoStyle (applyStyleToRange (\st -> StyledText (Bg Black) [st]) startOffset (cursorLoc, cursorLoc) [src]) in (newSrc, Nothing) markVirtualCursor _ cursorLoc (src, Just token) = let newSrc = StyledText NoStyle (applyStyleToRange (\st -> StyledText (FgBg White Red) [st]) (lcOffset $ getTokenLoc token) (cursorLoc, cursorLoc) [src]) in (newSrc, Just token) isPrintableArea :: Int -> Int -> Bool isPrintableArea y height = y >=0 && y < height instance KeyInput EditorWidget where getCursorInfo ref = do ew <- readWRef ref let tp = getTextContentStart (ewDim ew) (ewParams ew) let (sp, cs) = ewCursorInfo ew pure $ Just (addSp (ewPos ew) (addSp tp (moveUp (ewScrollOffset ew) sp)), cs) handleInput ref ev = do modifyWRefM ref (updateOnInput ev) instance Container EditorWidget Text where getContent ref = ewContent <$> readWRef ref setContent ref content = do modifyWRef ref (\w -> putCursor Nothing (min (ewCursor w) (T.length content - 1)) (w { ewContent = content })) between :: Int -> (Int, Int) -> Bool between a (b, c) = (b <= a) && (a <= c) insertCharAt :: Char -> Int -> Text -> Text insertCharAt c offset t = T.append (T.take offset t) (T.cons c (T.drop offset t)) replaceCharAt :: Char -> Int -> Text -> Text replaceCharAt c offset t = T.append (T.take (max 0 (offset - 1)) t) (T.cons c (T.drop offset t)) removeCharAt :: Int -> Text -> Text removeCharAt offset t = case T.drop offset t of "" -> t dropped -> T.append (T.take offset t) (T.tail dropped) -- TODO: Move this logic to autocomplete handler getAutoCompleteKey :: (HasLog m, MonadIO m) => Text -> Int -> m Text getAutoCompleteKey cnt cursoroffset = do let contentTillCursor = T.take cursoroffset cnt case T.unsnoc contentTillCursor of Just (_, ' ') -> pure "" _ -> pure $ getLastWord "" contentTillCursor where getLastWord :: Text -> Text -> Text getLastWord r c = case T.unsnoc c of Nothing -> r Just (p, lc@((\ch -> T.cons ch "") -> lct)) -> if lct `T.isInfixOf` " \n(.,+-*/:{" then r else getLastWord (T.cons lc r) p replaceLastWord :: (HasLog m, MonadIO m) => Text -> Int -> Text -> m (Text, Int) replaceLastWord content cursor replacement = do lastword <- getAutoCompleteKey content cursor let lastWordLen = T.length lastword replacementLen = T.length replacement let newContent = T.concat [T.take (cursor - lastWordLen) content, replacement, T.drop cursor content] pure (newContent, (replacementLen - lastWordLen)) mkRange :: (Int, Int) -> (Int, Int) mkRange (r1, r2) = (min r1 r2, max r1 r2) data CursorMovement = CVert CursorMovementVertical | CRIGHT Int | CLEFT | CHOME | CEND data CursorMovementVertical = CUP | CDOWN adjustScrollOffset :: WidgetC m => WRef EditorWidget -> m () adjustScrollOffset r = modifyWRef r (\ew -> putCursor Nothing 0 ew) scrollToBottom :: WidgetC m => WRef EditorWidget -> m () scrollToBottom ewRef = do w <- readWRef ewRef let ch = (T.length $ ewContent w) - 1 modifyWRef ewRef (\ew -> putCursor Nothing ch ew) putCursor :: Maybe [Int] -> Int -> EditorWidget -> EditorWidget putCursor mll nc ew = let lineLengths = fromMaybe (getLineLengths ew) mll (currentCursorSp, _) = ewCursorInfo ew in case offsetToScreenPos contentWidth lineLengths nc of Just (newsp, cl) -> let newEw = ew { ewCursorLine = cl, ewCursorInfo = (newsp, cStyle), ewCursor = nc } newScrollOffset = if (sY currentCursorSp /= sY newsp) then computeScrollOffset newEw newsp else ewScrollOffset newEw in newEw { ewScrollOffset = newScrollOffset } Nothing -> ew where (_, cStyle) = ewCursorInfo ew (_, contentWidth) = getTextPaddingAndSoftLineLength (ewDim ew) (ewParams ew) getContetLines :: Text -> [Text] getContetLines = T.split (== '\n') getLineLengths :: EditorWidget -> [Int] getLineLengths ew = let contentLines = getContetLines (ewContent ew) -- Shoulnd't use T.lines here as behavior is different when the last char is a new line. in T.length <$> contentLines moveCursor :: EditorWidget -> CursorMovement -> EditorWidget moveCursor ew cm = case cm of CVert v -> moveCursorVertical ew v CRIGHT o -> newWidget o CLEFT -> newWidget (-1) CHOME -> let newLineOffset = (sum (DL.take (ewCursorLine ew - 1) lineLengths)) + (ewCursorLine ew - 1) in newWidget (newLineOffset - currentCursor) CEND -> let newLineOffset = case T.findIndex (== '\n') (T.drop currentCursor content) of Just off -> off Nothing -> T.length content - currentCursor in newWidget newLineOffset where newWidget off = let nc = min (T.length (ewContent ew)) (currentCursor + off) in putCursor (Just lineLengths) nc ew currentCursor = ewCursor ew lineLengths = getLineLengths ew content = ewContent ew computeScrollOffset :: EditorWidget -> ScreenPos -> Int computeScrollOffset ew newSp = let epBorderSize = if (epBorder $ ewParams ew) then 1 else 0 contentHeight = (diH $ ewDim ew) - (2 * epBorderSize) cursorOverflow = (sY newSp - (ewScrollOffset ew)) - (contentHeight - 1) cursorUnderflow = (ewScrollOffset ew) - (sY newSp) in if cursorOverflow > 0 then ewScrollOffset ew + cursorOverflow else if cursorUnderflow > 0 then ewScrollOffset ew - cursorUnderflow else ewScrollOffset ew moveCursorVertical :: EditorWidget -> CursorMovementVertical -> EditorWidget moveCursorVertical ew cm = case screenPosToOffset lineLengths contentWidth newSp' of Just (newCursor, cursorLine, newSp) -> let newScrollOffset = computeScrollOffset ew newSp in ew { ewCursorLine = cursorLine, ewScrollOffset = newScrollOffset, ewCursorInfo = (newSp, cStyle), ewCursor = newCursor } Nothing -> ew where newSp' = case cm of CUP -> moveUp 1 currentSp CDOWN -> moveDown 1 currentSp (currentSp, cStyle) = ewCursorInfo ew lineLengths = T.length <$> contentLines contentLines = getContetLines $ ewContent ew (_, contentWidth) = getTextPaddingAndSoftLineLength (ewDim ew) (ewParams ew) updateOnInput :: forall m. WidgetC m => KeyEvent -> EditorWidget -> m EditorWidget updateOnInput ev ew = do if (ewReadOnly ew) then pure ew else do case ev of KeyCtrl _ sh _ ArrowUp -> simpleCursorMovement (CVert CUP) sh KeyCtrl _ sh _ ArrowDown -> simpleCursorMovement (CVert CDOWN) sh KeyCtrl _ sh _ End -> simpleCursorMovement CEND sh KeyCtrl _ sh _ Home -> simpleCursorMovement CHOME sh KeyCtrl _ sh _ ArrowRight -> simpleCursorMovement (CRIGHT 1) sh KeyCtrl _ sh _ ArrowLeft -> simpleCursorMovement CLEFT sh KeyCtrl _ _ _ Del -> do let existing = ewContent ew cursor = ewCursor ew let newEw = ew { ewContent = removeCharAt cursor existing } checkShowAc newEw pure newEw KeyCtrl _ _ _ Esc -> do hideAc ew pure ew KeyCtrl _ _ _ Backspace -> if ewCursor ew > 0 then let existing = ewContent ew cursor = ewCursor ew in do let newEw = moveCursor (ew { ewContent = removeCharAt (cursor - 1) existing }) CLEFT checkShowAc newEw pure newEw else pure ew KeyCtrl _ _ _ Return -> do isAutoCompleting ew ev >>= \case False -> updateOnInput (KeyChar False False False '\n') ew True -> do case ewAutocompleteWidget ew of Just (SomeWidgetRef ac) -> withCapability (SelectableCap ac) $ do selection <- getSelection ac (newContent, cursorShift) <- replaceLastWord (ewContent ew) (ewCursor ew) selection hideAc ew pure $ moveCursor (ew { ewContent = newContent }) (CRIGHT cursorShift) Nothing -> pure ew KeyChar False False False (convertTab -> c) -> case ewInsertMode ew of InsertMode -> do let newContent = insertCharAt c (ewCursor ew) (ewContent ew) let newEw = moveCursor (ew { ewContent = newContent}) (CRIGHT 1) checkShowAc newEw pure newEw ReplaceMode -> pure ew -- disable replace mode now _ -> pure ew where simpleCursorMovement :: CursorMovement -> Bool -> m EditorWidget simpleCursorMovement cm sh = do isAutoCompleting ew ev >>= \case True -> pure ew False -> do let oldCursor = ewCursor ew let newEw = moveCursor ew cm let newCursor = ewCursor newEw let newSelection = if sh then case ewSelection ew of Just (ss, _) -> Just $ mkRange (ss, newCursor - 1) Nothing -> Just $ mkRange (oldCursor, newCursor - 1) else Nothing pure $ newEw { ewSelection = newSelection } isAutoCompleting ew' key = case ewAutocompleteWidget ew' of Just (SomeWidgetRef ac) -> withCapability (DrawableCap ac) $ do getVisibility ac >>= \case True -> withCapability (KeyInputCap ac) $ do handleInput ac key pure True False -> pure False Nothing -> pure False hideAc ew' = do case ewAutocompleteWidget ew' of Just (SomeWidgetRef ac) -> withCapability (DrawableCap ac) $ do setVisibility ac False Nothing -> pure () checkShowAc ew' = do case ewAutocompleteWidget ew' of Just (SomeWidgetRef ac) -> do key <- getAutoCompleteKey (ewContent ew') (ewCursor ew') withCapability (DrawableCap ac) $ do if T.null key then do setVisibility ac False else do (ewAutocompleteSuggestions ew) key >>= \case [] -> setVisibility ac False [s] -> if (fst s) == key then setVisibility ac False else pass suggestions@(_:_) -> withCapability (ContainerCap ac (Proxy @[(Text, Text)])) $ do setContent ac (sortBy (\(a1, _) (a2, _) -> compare (T.length a1) (T.length a2)) suggestions) setVisibility ac True pure () Nothing -> pure () convertTab '\t' = ' ' convertTab c = c editor :: forall m. WidgetC m => (forall m1. MonadIO m1 => Text -> m1 [(Text, Text)]) -> Maybe SomeTokenStream -> m (WRef EditorWidget) editor mautocomplete mts = newWRef $ EditorWidget { ewContent = "" , ewDim = Dimensions 0 0 , ewVisibility = True , ewPos = ScreenPos 0 0 , ewCursor = 0 , ewDebugLocation = Nothing , ewParseErrorLocation = Nothing , ewWordWrap = True , eweHasFocus = False , ewScrollOffset = 0 , ewInsertMode = InsertMode , ewTokenStream = mts , ewAutocompleteWidget = Nothing , ewAutocompleteSuggestions = mautocomplete , ewReadOnly = False , ewCursorInfo = (ScreenPos 0 0, Bar) , ewSelection = Nothing , ewShowVirtualCursor = False , ewParams = defaultEp , ewCursorLine = 1 }