fontification for strings, guards, returns, comments

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

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)
+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
 -- 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
+returns :: BS.ByteString -> [Fontification]
-testFontify :: String -> Int -> [Fontification]
+returns = matchAttrAll "return" "\\^.*;"
-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)
 
+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 = []

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)
+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 == 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
+          f       <- getLine 
-          exists <- doesFileExist f
+          exists  <- doesFileExist f 
           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.
 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