hsedit/editor.hs

import Brick
import Brick.Markup
import Data.Maybe
import Data.Monoid
import Data.List
import Data.Tuple
import Data.Default
import Data.Text (pack, singleton, unpack)
import Data.Text.Markup
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent
import Control.DeepSeq
import System.Environment
import qualified Brick.Widgets.Edit as E
import qualified Graphics.Vty as V

import Control.Exception.Base
import Debug.Trace

data Name = Text deriving (Ord, Show, Eq)
type St = E.Editor Name

brackets = [('(',')'),('[',']'),('{','}')]

initialState :: String -> St
initialState = E.editor Text drawContent Nothing

drawContent :: [String] -> Widget n
drawContent = markup . (createMarkup []) . unlinesWA

-- workaround because empty lines don't work with Markup
unlinesWA :: [String] -> String
unlinesWA [] = ""
unlinesWA (l:ls) = l ++ (" \n" ++ unlinesWA ls)

createMarkup :: String -> String -> Markup V.Attr
createMarkup _ [] = mempty
createMarkup p s@('"':ss) = case i of
                            Just n -> (pack (take (2+n) s) @@ fg V.blue) <> (createMarkup (reverse (take (2+n) s) ++ s) (drop (1+n) ss))
                            Nothing -> pack s @@ fg V.red
    where i = elemIndex '"' ss
createMarkup p (c:ss) 
    | isJust ob && mismatched (fromJust ob) ss 1 
        || isJust cb && mismatched (swap $ fromJust cb) p 1 = (singleton c @@ bg V.red) <> r
    | otherwise = (singleton c @@ fg V.white) <> r
        where   ob = find ((== c).fst) brackets
                cb = find ((== c).snd) brackets
                r = createMarkup (c:p) ss
        
mismatched :: (Char, Char) -> String -> Int -> Bool
mismatched _ _ 0 = False
mismatched _ [] _ = True
mismatched b@(ob, cb) (c:cs) d
    | c == ob = mismatched b cs $ d+1
    | c == cb = mismatched b cs $ d-1
    | otherwise = mismatched b cs d

drawUI :: St -> [Widget Name]
drawUI st = [E.renderEditor True st]

appCursor :: St -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appCursor st c = Just (head c)

appEvent :: String -> St -> V.Event -> EventM Name (Next St)
appEvent s st ev =
    case ev of
        V.EvKey V.KEsc [] -> halt st
        V.EvKey (V.KChar 'c') [V.MCtrl] -> halt st
        V.EvKey (V.KChar 's') [V.MCtrl] -> liftIO (writeFile s (unlines $ E.getEditContents $ st)) >> continue st
        _ -> continue =<< E.handleEditorEvent ev st

theApp :: String -> App St V.Event Name 
theApp s =
    App { appDraw = drawUI
          , appChooseCursor = showFirstCursor
          , appHandleEvent = appEvent s
          , appStartEvent = return
          , appAttrMap = const (attrMap V.defAttr [ ])
          , appLiftVtyEvent = id
          }

main = do
    f <- do
            a <- getArgs
            return $ head a
    c <- readFile f
    st <- defaultMain (theApp f) (initialState c)
    void $ return st
--    putStrLn $ unlines $ E.getEditContents $ st