fontification for strings, guards, returns, comments

This commit is contained in:
Armin Friedl 2016-08-11 04:17:42 +02:00
parent 21567d6a15
commit 81298593c1
3 changed files with 84 additions and 42 deletions

View file

@ -60,14 +60,17 @@ executable hedit
other-extensions: TemplateHaskell other-extensions: TemplateHaskell
-- Other library packages from which modules are imported. -- 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, 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, microlens >=0.4 && <0.5, microlens-th >=0.4 && <0.5,
-- for Control.Monal.IO.Class -- for Control.Monal.IO.Class
transformers >=0.5 && <0.6, transformers >=0.5 && <0.6,
directory, directory,
text-zipper text-zipper,
bytestring,
array,
regex-tdfa
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src, src/App hs-source-dirs: src, src/App

View file

@ -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 module Fontifier (fontMap, fontify, Fontification(..)) where
{---- Imports ----} {---- Imports ----}
@ -6,9 +13,12 @@ module Fontifier (fontMap, fontify, Fontification(..)) where
import Brick.AttrMap (AttrName, attrName) import Brick.AttrMap (AttrName, attrName)
import Brick.Util (bg, fg) import Brick.Util (bg, fg)
import qualified Graphics.Vty as Vty import qualified Graphics.Vty as Vty
import qualified Text.Regex.TDFA as Tdfa
---- Various ---- ---- Various ----
import Data.Array
import qualified Data.ByteString as BS
import Data.String
{---- Type Definitions ----} {---- Type Definitions ----}
-- defines an attribute for a text slice -- defines an attribute for a text slice
@ -20,24 +30,48 @@ data Fontification = FT { ftStart :: Int -- start index in string
{---- Functions ----} {---- Functions ----}
fontMap :: [(AttrName, Vty.Attr)] fontMap :: [(AttrName, Vty.Attr)]
fontMap = [ (attrName "assignment" , fg Vty.blue) fontMap = [ (attrName "assignment" , fg Vty.blue)
, (attrName "return" , fg Vty.green) , (attrName "return" , fg Vty.green)
, (attrName "guard" , fg Vty.yellow) , (attrName "guard" , fg Vty.yellow)
, (attrName "comment" , fg Vty.green) , (attrName "comment" , fg Vty.green)
, (attrName "err_braces" , fg Vty.red) -- unbalanced braces , (attrName "string" , fg Vty.green)
, (attrName "err_string" , fg Vty.red) -- unterminated strings , (attrName "err_braces" , fg Vty.red) -- unbalanced braces
, (attrName "err_string" , fg Vty.red) -- unterminated strings
] ]
-- calls the fontification functions -- calls the fontification functions
-- and returns a list of attributes for text slices -- and returns a list of attributes for text slices
fontify :: String -> [Fontification] 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 returns :: BS.ByteString -> [Fontification]
testFontify :: String -> Int -> [Fontification] returns = matchAttrAll "return" "\\^.*;"
testFontify [] _ = []
testFontify (s:ss) c = if s == 'a' strings :: BS.ByteString -> [Fontification]
then (FT c (c+1) (attrName "err_string")): testFontify ss (c+1) strings = matchAttrAll "string" "\".*\""
else testFontify ss (c+1)
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 = []

View file

@ -67,7 +67,7 @@ runEditor f = do
theApp :: App HeditState Vty.Event Names theApp :: App HeditState Vty.Event Names
theApp = App { appDraw = drawUI theApp = App { appDraw = drawUI
, appChooseCursor = showFirstCursor , appChooseCursor = showFirstCursor
, appHandleEvent = appEvent , appHandleEvent = handleEvent
, appStartEvent = return , appStartEvent = return
, appAttrMap = const $ getAttrMap , appAttrMap = const $ getAttrMap
, appLiftVtyEvent = id , appLiftVtyEvent = id
@ -77,15 +77,9 @@ initialState :: FilePath -> String -> HeditState
initialState f content = HS (EditWidget.editor Hedit drawHeditText Nothing content) initialState f content = HS (EditWidget.editor Hedit drawHeditText Nothing content)
(f) (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
uiMap = attrMap Vty.defAttr uiMap = attrMap Vty.defAttr
[ (attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta) [ (attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta)
@ -93,6 +87,14 @@ uiMap = attrMap Vty.defAttr
, (attrName "commands" , Vty.white `on` Vty.magenta) , (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 :: HeditState -> [Widget Names]
drawUI st = vBox [titleBar, title, titleBar, commands] : [editWidget] drawUI st = vBox [titleBar, title, titleBar, commands] : [editWidget]
-- the where is a bit ugly, for an intuitive understanding just don't look at it -- 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 -- that spans the whole width
-- 1 line high -- 1 line high
appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names) handleEvent :: HeditState -> Vty.Event -> EventM Names (Next HeditState)
appCursor st c = Just (head c) handleEvent st ev
appEvent :: HeditState -> Vty.Event -> EventM Names (Next HeditState)
appEvent st ev
| ev `elem` [esc, ctrl 'c'] = quit | ev `elem` [esc, ctrl 'c'] = quit
| ev == ctrl 's' = save >> BrickMain.continue st | ev == ctrl 's' = save >> BrickMain.continue st
| ev == ctrl 'o' = askForFileAndOpen | ev == ctrl 'o' = askForFileAndOpen
@ -130,24 +129,24 @@ appEvent st ev
insertFourSpaces = return $ insertString (replicate 4 ' ') st insertFourSpaces = return $ insertString (replicate 4 ' ') st
askForFileAndOpen = BrickMain.suspendAndResume $ do askForFileAndOpen = BrickMain.suspendAndResume $ do
putStrLn "Please enter file path: " putStrLn "Please enter file path: "
f <- getLine f <- getLine
exists <- doesFileExist f exists <- doesFileExist f
content <- if exists then readFile f else return [] content <- if exists then readFile f else return []
return $ st & file .~ f return $ st & file .~ f -- replaces old state
& hedit .~ EditWidget.editor Hedit drawHeditText Nothing content & 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. -- just don't ask what this does --- inserts a string, returns the state. end of story.
insertString :: String -> HeditState -> HeditState insertString :: String -> HeditState -> HeditState
insertString string st = st & hedit %~ insertString' string -- uses some fancy lense magic insertString string st = st & hedit %~ insertString' string -- uses some fancy lense magic
where insertString' [] e = e where insertString' [] e = e
insertString' (a:aa) e = insertString' aa insertChar 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 where insertChar = EditWidget.applyEdit (TextZipper.insertChar a) e
drawHeditText :: [String] -> Widget n drawHeditText :: [String] -> Widget n
drawHeditText lines = makeWidget $ makeMarkup $ getFontification text drawHeditText lines = makeWidget $ makeMarkup $ getFontification text
where makeWidget = markup -- just a synonym for Brick.Markup.markup 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 getFontification = Fontifier.fontify -- just a synonym
makeMarkup = fontifyToMarkup text -- curried fontifyToMarkup; needs an additional fontification list only 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 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 -- TODO Refactor
-- 1) Forget the monad thing that used to stand here, no need to -- 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 :: [(Char,Char)]
brackets = [('(',')'),('[',']'),('{','}')] 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 :: (Char, Char) -> String -> Int -> Bool
mismatched _ _ 0 = False mismatched _ _ 0 = False