fontifier with test-fontification, gui changed a bit

src/App/Fontifier.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}  -- needed for lenses
+module Fontifier (fontMap, fontify, Fontification(..)) where
-
-module Fontifier (fontMap, fontify) where
 
 {----  Imports  ----}
 
@@ -10,17 +8,14 @@ import           Brick.Util    (bg, fg)
 import qualified Graphics.Vty  as Vty
 
 ---- Various ----
-import           Lens.Micro
-import           Lens.Micro.TH (makeLenses)
 
 
 {---- Type Definitions ----}
 -- defines an attribute for a text slice
-data Fontification = FT { _ftStart :: Integer -- start index in string
+data Fontification = FT { ftStart :: Int      -- start index in string
-                        , _ftEnd   :: Integer -- end index in string
+                        , ftEnd   :: Int      -- end index in string
-                        , _ftAttr  :: String  -- attribute name
+                        , ftAttr  :: AttrName -- attribute name
-                        }
+                        } deriving (Show)
-makeLenses ''Fontification
 
 {---- Functions ----}
 
@@ -28,6 +23,7 @@ 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
           ]
@@ -35,4 +31,13 @@ fontMap = [ (attrName "assignment" , fg Vty.blue)
 -- calls the fontification functions
 -- and returns a list of attributes for text slices
 fontify :: String -> [Fontification]
-fontify s = []
+fontify s = testFontify s 0
+
+
+-- 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)
+                       

src/App/Gui.hs

@@ -1,6 +1,7 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
-module Gui (runEditor) where
+module Gui (runEditor, fontifyToMarkup) where
 
 
 {----  Imports  ----}
@@ -17,7 +18,8 @@ import qualified Graphics.Vty           as Vty
 
 ---- Text ----
 import           Data.Text              (pack, singleton, unpack)
-import           Data.Text.Markup       (Markup, toText, (@@))
+import           Data.Text.Markup       (Markup, fromText, markupSet, toText,
+                                         (@@))
 
 ---- Files ----
 import           System.Directory       (doesFileExist)
@@ -25,13 +27,14 @@ import           System.IO              (IOMode (..), hClose, hGetContents,
                                          openFile)
 
 ---- Markup ----
-import qualified Fontifier              as Fontifier
+import           Fontifier
 
 ---- Various ----
 import           Control.Monad.IO.Class (liftIO)
 import           Data.List
 import           Data.Maybe
 import           Data.Monoid            (mempty, (<>))
+import           Data.String            (fromString)
 import           Data.Tuple
 import           Lens.Micro             ((^.))
 import           Lens.Micro.TH          (makeLenses)
@@ -70,36 +73,38 @@ theApp = App { appDraw         = drawUI
              }
 
 initialState :: FilePath -> String -> HeditState
-initialState f content = HS (EditWidget.editor Hedit drawContent Nothing content)
+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
+-- add functions that return [(AttrName,Attr)] lists into foldl list
 -- for additional attributes
 getAttrMap :: AttrMap
 getAttrMap = foldl merge mainMap [Fontifier.fontMap]
   where merge map list = applyAttrMappings list map -- just reverses arguments of apply
         mainMap = attrMap Vty.defAttr [
-           (attrName "blackOnWhite", Vty.brightBlack `on` Vty.brightWhite),
+           (attrName "blackOnWhite", Vty.white `on` Vty.brightMagenta),
            (attrName "title", foldl Vty.withStyle (Vty.blue `on` Vty.brightYellow)
                                                   [Vty.standout,Vty.bold,
-                                                   Vty.blink])
+                                                   Vty.blink]),
+           (attrName "commands", Vty.white `on` Vty.magenta)
           ]
 
 drawUI :: HeditState -> [Widget Names]
-drawUI st = stackTopDown [title, hBorder, commands, hBorder] ++ [editWidget]
+drawUI st = stackTopDown [titleBar, title, titleBar, commands] ++ [editWidget]
-  where editWidget = padTop (Pad 4) $ EditWidget.renderEditor True (st^.hedit)
+  where editWidget = padTop (Pad 5) $ EditWidget.renderEditor True (st^.hedit)
         hBorder = BorderWidgets.hBorder
-        commands = hBox [str "Commands: "
+        commands = withAttr (attrName "commands") $ padLeft Max $ hBox [ str "^S"
-                        , withAttr (attrName "blackOnWhite") $ str "^S"
                                                                        , str "...Save"
-                        , withAttr (attrName "blackOnWhite") $ str "^C/Esc"
+                                                                       , str "  │  "
+                                                                       , str "^C/Esc"
                                                                        , str "...Quit "
                                                                        ]
         title = withAttr (attrName "title") $ CenterWidget.hCenter $
                         str "HEDIT - The Not So Fancy Editor"
+        titleBar = withAttr (attrName "title") $ CenterWidget.hCenter $ str " "
         stackTopDown widgets = [vBox widgets]  -- doesn't work with editor (at least i don't know how)
 
 appCursor :: HeditState -> [CursorLocation Names] -> Maybe (CursorLocation Names)
@@ -119,8 +124,27 @@ appEvent st ev
         forwardToWidget = handleEventLensed st hedit EditWidget.handleEditorEvent ev
 
 
+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
+        getFontification = Fontifier.fontify -- just a synonym
+        makeMarkup = fontifyToMarkup text    -- curried fontifyToMarkup; needs an additional fontification list only
 
+fontifyToMarkup :: String -> [Fontification] -> Markup AttrName
+fontifyToMarkup text fontification = fontifyToMarkup' baseMarkup fontification
+  -- fromText marks the given text with the default markup
+  -- fromString creates a Data.Text from a String (works because of OverloadedStrings extension)
+  where baseMarkup = (fromText $ fromString text)
 
+-- Workhorse of fontifyToMarkup
+-- merges all the fontification information into the given Markup and
+-- returns the merged markup
+fontifyToMarkup' :: Markup AttrName -> [Fontification] -> Markup AttrName
+fontifyToMarkup' markup [] = markup
+fontifyToMarkup' markup (f:ff) = fontifyToMarkup' (markupSet slice attribute markup) ff
+  where slice = ((ftStart f),(ftEnd f)-(ftStart f)) -- slice = (startIndex, length)
+        attribute = ftAttr f