attic/hsedit
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

fontification for strings, guards, returns, comments

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

9
hedit.cabal
View file

@ -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

64
src/App/Fontifier.hs
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
{---- 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 = []

53
src/App/Gui.hs
View file

@ -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