diff --git a/hedit.cabal b/hedit.cabal index 6b9ab7d..985e3ce 100644 --- a/hedit.cabal +++ b/hedit.cabal @@ -60,14 +60,17 @@ executable hedit other-extensions: TemplateHaskell -- Other library packages from which modules are imported. - build-depends: base >=4.7 && <4.8, + build-depends: base, brick >=0.8 && <0.9, vty >=5.7 && <5.8, - text >=1.1 && <1.2, + text, microlens >=0.4 && <0.5, microlens-th >=0.4 && <0.5, -- for Control.Monal.IO.Class transformers >=0.5 && <0.6, directory, - text-zipper + text-zipper, + bytestring, + array, + regex-tdfa -- Directories containing source files. hs-source-dirs: src, src/App diff --git a/src/App/Fontifier.hs b/src/App/Fontifier.hs index 733d57e..f5a4832 100644 --- a/src/App/Fontifier.hs +++ b/src/App/Fontifier.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- I somewhat believe this can be done much better +-- with Monads or Arrows and an eDSL. Parsers like +-- Parsec are already half way there but I just +-- can't wrap my head around how to adapt the +-- concept to our use case. module Fontifier (fontMap, fontify, Fontification(..)) where {---- Imports ----} @@ -6,9 +13,12 @@ module Fontifier (fontMap, fontify, Fontification(..)) where import Brick.AttrMap (AttrName, attrName) import Brick.Util (bg, fg) import qualified Graphics.Vty as Vty +import qualified Text.Regex.TDFA as Tdfa ---- Various ---- - +import Data.Array +import qualified Data.ByteString as BS +import Data.String {---- Type Definitions ----} -- defines an attribute for a text slice @@ -20,24 +30,48 @@ data Fontification = FT { ftStart :: Int -- start index in string {---- Functions ----} fontMap :: [(AttrName, Vty.Attr)] -fontMap = [ (attrName "assignment" , fg Vty.blue) - , (attrName "return" , fg Vty.green) - , (attrName "guard" , fg Vty.yellow) - , (attrName "comment" , fg Vty.green) - , (attrName "err_braces" , fg Vty.red) -- unbalanced braces - , (attrName "err_string" , fg Vty.red) -- unterminated strings +fontMap = [ (attrName "assignment" , fg Vty.blue) + , (attrName "return" , fg Vty.green) + , (attrName "guard" , fg Vty.yellow) + , (attrName "comment" , fg Vty.green) + , (attrName "string" , fg Vty.green) + , (attrName "err_braces" , fg Vty.red) -- unbalanced braces + , (attrName "err_string" , fg Vty.red) -- unterminated strings ] -- calls the fontification functions -- and returns a list of attributes for text slices fontify :: String -> [Fontification] -fontify s = testFontify s 0 +fontify s = concat [guards bs, returns bs, strings bs, comments bs] + where bs = fromString s +guards :: BS.ByteString -> [Fontification] +guards = matchAttrAll "guard" "\\[.*:.*\\]" --- fontifies every occurence of a as error -testFontify :: String -> Int -> [Fontification] -testFontify [] _ = [] -testFontify (s:ss) c = if s == 'a' - then (FT c (c+1) (attrName "err_string")): testFontify ss (c+1) - else testFontify ss (c+1) - +returns :: BS.ByteString -> [Fontification] +returns = matchAttrAll "return" "\\^.*;" + +strings :: BS.ByteString -> [Fontification] +strings = matchAttrAll "string" "\".*\"" + +comments :: BS.ByteString -> [Fontification] +comments = matchAttrAll "comment" "%.*\n" + +matchAttrAll :: String -> String -> BS.ByteString -> [Fontification] +matchAttrAll attribute regexString bs = + let regex = Tdfa.makeRegex regexString :: Tdfa.Regex + in matchToFT (attrName attribute) $ Tdfa.matchAll regex bs + +-- Converts contents of a MatchArray (result of a regex matching) +-- to a fontification with the given attribute +matchToFT :: AttrName -> [Tdfa.MatchArray] -> [Fontification] +matchToFT attrName matchArray = matchToFT' matchArray + where matchToFT' [] = [] + matchToFT' (m:ms) = + let match = m ! 0 + start = fst match + end = (fst match) + (snd match) + in FT {ftStart = start, ftEnd = end, ftAttr = attrName} : matchToFT' ms + +mismatchedBrackets :: BS.ByteString -> [Fontification] +mismatchedBrackets bs = [] diff --git a/src/App/Gui.hs b/src/App/Gui.hs index 345075a..6b6d1e3 100644 --- a/src/App/Gui.hs +++ b/src/App/Gui.hs @@ -67,7 +67,7 @@ runEditor f = do theApp :: App HeditState Vty.Event Names theApp = App { appDraw = drawUI , appChooseCursor = showFirstCursor - , appHandleEvent = appEvent + , appHandleEvent = handleEvent , appStartEvent = return , appAttrMap = const $ getAttrMap , appLiftVtyEvent = id @@ -77,15 +77,9 @@ initialState :: FilePath -> String -> HeditState initialState f content = HS (EditWidget.editor Hedit drawHeditText Nothing content) (f) -drawContent :: [String] -> Widget n -drawContent = markup . (createMarkup []) . unlines - --- add functions that return [(AttrName,Attr)] lists into foldl list --- for additional attributes -getAttrMap :: AttrMap -getAttrMap = foldl merge uiMap [Fontifier.fontMap] - where merge map list = applyAttrMappings list map -- just reverses arguments of apply +-- markup specifications bound to "high-level" names, +-- can be used to designate strings with style uiMap :: AttrMap uiMap = attrMap Vty.defAttr [ (attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta) @@ -93,6 +87,14 @@ uiMap = attrMap Vty.defAttr , (attrName "commands" , Vty.white `on` Vty.magenta) ] +-- returns the markup specifications defined in this module (uiMap) merged +-- together with specialized markup definitions defined somewhere else +-- -> add functions that return [(AttrName,Attr)] lists into foldl list to +-- add a specialized markup specificaiton +getAttrMap :: AttrMap +getAttrMap = foldl merge uiMap [Fontifier.fontMap] + where merge map list = applyAttrMappings list map -- just reverses arguments of apply + drawUI :: HeditState -> [Widget Names] drawUI st = vBox [titleBar, title, titleBar, commands] : [editWidget] -- the where is a bit ugly, for an intuitive understanding just don't look at it @@ -109,11 +111,8 @@ drawUI st = vBox [titleBar, title, titleBar, commands] : [editWidget] -- that spans the whole width -- 1 line high -appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names) -appCursor st c = Just (head c) - -appEvent :: HeditState -> Vty.Event -> EventM Names (Next HeditState) -appEvent st ev +handleEvent :: HeditState -> Vty.Event -> EventM Names (Next HeditState) +handleEvent st ev | ev `elem` [esc, ctrl 'c'] = quit | ev == ctrl 's' = save >> BrickMain.continue st | ev == ctrl 'o' = askForFileAndOpen @@ -130,24 +129,24 @@ appEvent st ev insertFourSpaces = return $ insertString (replicate 4 ' ') st askForFileAndOpen = BrickMain.suspendAndResume $ do putStrLn "Please enter file path: " - f <- getLine - exists <- doesFileExist f + f <- getLine + exists <- doesFileExist f content <- if exists then readFile f else return [] - return $ st & file .~ f - & hedit .~ EditWidget.editor Hedit drawHeditText Nothing content + return $ st & file .~ f -- replaces old state + & hedit .~ EditWidget.editor Hedit drawHeditText Nothing content -- with new text/file -- just don't ask what this does --- inserts a string, returns the state. end of story. insertString :: String -> HeditState -> HeditState insertString string st = st & hedit %~ insertString' string -- uses some fancy lense magic where insertString' [] e = e insertString' (a:aa) e = insertString' aa insertChar - -- inserts char a returns resulting editor + -- inserts char a, returns resulting editor where insertChar = EditWidget.applyEdit (TextZipper.insertChar a) e drawHeditText :: [String] -> Widget n drawHeditText lines = makeWidget $ makeMarkup $ getFontification text where makeWidget = markup -- just a synonym for Brick.Markup.markup - text = unlinesWA lines -- make a single text junk from splitted lines + text = concatMap (++" \n") lines -- make a single text junk from splitted lines, replaces unlinesWA getFontification = Fontifier.fontify -- just a synonym makeMarkup = fontifyToMarkup text -- curried fontifyToMarkup; needs an additional fontification list only @@ -167,6 +166,16 @@ fontifyToMarkup' markup (f:ff) = fontifyToMarkup' (markupSet slice attribute mar attribute = ftAttr f +-- TODO had to name this function drawHeditText to test +-- out the fontifier w/o deleting the old thing, +-- think it won't be needed -> delete? +drawContent :: [String] -> Widget n +drawContent = markup . (createMarkup []) . unlines + +-- TODO is this needed/used somewhere? i don't see it -> delete? +appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names) +appCursor st c = Just (head c) + -- TODO Refactor -- 1) Forget the monad thing that used to stand here, no need to @@ -179,10 +188,6 @@ fontifyToMarkup' markup (f:ff) = fontifyToMarkup' (markupSet slice attribute mar brackets :: [(Char,Char)] brackets = [('(',')'),('[',']'),('{','}')] --- workaround because empty lines don't work with Markup -unlinesWA :: [String] -> String -unlinesWA [] = "" -unlinesWA (l:ls) = l ++ (" \n" ++ unlinesWA ls) mismatched :: (Char, Char) -> String -> Int -> Bool mismatched _ _ 0 = False