unterminated strings, unmatched brackets, assignments

src/App/Fontifier.hs

@@ -10,14 +10,14 @@ module Fontifier (fontMap, fontify, Fontification(..)) where
 {----  Imports  ----}
 
 ---- Brick, for markup specifications ----
-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 ----
 import           Data.Array
-import Data.String
+import           Data.String
 
 {---- Type Definitions ----}
 -- defines an attribute for a text slice
@@ -26,33 +26,42 @@ data Fontification = FT { ftStart :: Int      -- start index in string
                         , ftAttr  :: AttrName -- attribute name
                         } deriving (Show)
 
+-- TODO we could re-structure functions below to make
+-- more use of custom types and buy us some more
+-- guarantees from the compiler
+
 {---- 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.magenta)
+          , (attrName "comment"      , fg Vty.magenta)
-          , (attrName "string"      , fg Vty.green)
+          , (attrName "string"       , fg Vty.green)
-          , (attrName "err_braces"  , fg Vty.red) -- unbalanced braces
+          , (attrName "err_brackets" , bg Vty.red) -- unbalanced brackets
-          , (attrName "err_string"  , fg Vty.red) -- unterminated strings
+          , (attrName "err_string"   , Vty.withStyle (fg Vty.red) Vty.underline) -- unterminated strings
           ]
 
 -- calls the fontification functions
--- and returns a list of attributes for text slices
+-- and returns a list of attributes for text slices.
--- fontification functions must take an IsString
+-- Fontification functions must take an IsString
 -- (either a ByteString, Text or normal String) and
 -- return a [Fontification] list
 fontify :: String -> [Fontification]
-fontify = concatApply [guards, returns, strings, comments]
+fontify = concatApply [ assignments, returns
+                      , untermStrings, strings
+                      , guards, comments
+                      , mismatchedBrackets]
           
 
--- applies the function in order
+-- applies the functions in order
 -- the fontification of the last function overrules
--- all previous ones in case more than one matches,
+-- all previous ones in case more than one matches for a slice.
--- the last function has the highest precedence
+-- The last function has the highest precedence.
--- can be useful to make e.g. comments "stronger" than strings
+-- This can be useful to make e.g. comments "stronger" than strings:
--- a string in a comment is then fontified as comment
+-- A string in a comment is then fontified as comment.
+-- This works because [Fontification] is applied in order in Gui.hs.
+-- We /could/ also enforce this by a special type for [Fontification]
 concatApply :: [(String -> [Fontification])] -> String -> [Fontification]
 concatApply [] _ = []
 concatApply (f:fs) s = (f $ fromString s) ++ concatApply fs s
@@ -62,6 +71,22 @@ concatApply (f:fs) s = (f $ fromString s) ++ concatApply fs s
 concatRevply :: [(String -> [Fontification])] -> String -> [Fontification]
 concatRevply fs = concatApply (reverse fs)
 
+-- TODO: most of the .+ don't actually allow any whitespace-like character
+-- maybe we should use \w instead?
+-- regexes can be improved in many ways i think
+-- TODO2: We could pack the "attr" "regex" into a type and run through
+-- them in a function
+--      -> 1. The definitions would be in one place and not spilled
+--            over the whole file in these mini-functions
+--      -> 2. We could make Fontifier.hs even more general and provide:
+--            font definition, regexes and custom font functions
+--            through another file. This way we could define
+--            fontification for >1 grammer. Not that this is
+--            demanded by the assignment ^^
+
+assignments :: String -> [Fontification]
+assignments = matchAttrAll "assignment" "\\**.+=.+;"
+
 guards :: String -> [Fontification]
 guards = matchAttrAll "guard" "\\[.+:.+\\]"
 
@@ -71,8 +96,11 @@ returns = matchAttrAll "return" "\\^.+;"
 strings :: String -> [Fontification]
 strings = matchAttrAll "string" "\".*\""
 
+untermStrings :: String -> [Fontification]
+untermStrings = matchAttrAll "err_string" "\".*\"[^\\;]" -- string is unterm if it isn't inside a guard (starts with '[') and isn't terminated by ';'
+
 comments :: String -> [Fontification]
-comments = matchAttrAll "comment" "%.*\n"
+comments = matchAttrAll "comment" "%.*"
 
 matchAttrAll :: String -> String -> String -> [Fontification]
 matchAttrAll attribute regexString bs =
@@ -83,12 +111,63 @@ matchAttrAll attribute regexString bs =
 -- to a fontification with the given attribute
 matchToFT :: AttrName -> [Tdfa.MatchArray] -> [Fontification]
 matchToFT attrName matchArray = matchToFT' matchArray
-  where matchToFT' [] = []
+  where matchToFT' []     = []
         matchToFT' (m:ms) =
-          let match = m ! 0
+          let match = m ! 0 -- get 1st elem of match array (this is the whole match, which we want)
               start = fst match
-              end = (fst match) + (snd match)
+              end   = (fst match) + (snd match)
-          in FT {ftStart = start, ftEnd = end, ftAttr = attrName} : matchToFT' ms
+          in (FT start end attrName) : matchToFT' ms
+
+-- TODO per se regexes are too weak to find matching
+-- things. We could use a regex lib that supports
+-- backreferences to achieve this though (i think)
+-- But this:
+-- a) is not so easy to get completely right
+-- (http://www.regular-expressions.info/backref.html)
+-- b) may backtrack a lot (but is also more powerful than what we have below)
+-- c) tdfa lib is one of or the most efficient lib(s) for haskell (i think)
 
 mismatchedBrackets :: String -> [Fontification]
-mismatchedBrackets bs = []
+mismatchedBrackets s = concatMap fontifyMismatched pairs
+  where fontifyMismatched = mismatched (attrName "err_brackets") s
+        pairs = [('(',')'),('[',']'),('{','}')]
+
+mismatched :: AttrName -> String -> (Char, Char) -> [Fontification]
+mismatched attrName s (open, close) = slicesToFT attrName $ (fst orphans)++(snd orphans)
+  where orphans = mismatched' s 0 ([],[])
+        stringsFts = strings s  -- this is ugly
+        commentsFts = comments s -- this is ugly
+        mismatched' [] _ ophs = ophs
+        mismatched' (curChr:restStr) ix ophs
+          -- 1. this is ugly, 2. if it's already fontified, go on
+          | or $ map (isFontified (ix,ix+1)) [stringsFts, commentsFts] = mismatched' restStr (ix+1) ophs
+          -- if we encounter an open it is an orphan until we find a close
+          -- chars are always 1 long -> (ix,ix+1)
+          -- use of (:) reverses the occurences but is more efficient than (++)
+          | curChr == open = mismatched' restStr (ix+1) ((ix, ix+1):(fst ophs), snd ophs)
+          -- if we encounter a close delete nearest open or mark as orphan itself
+          | curChr == close = case null (fst ophs) of
+              -- if orphans is empty the close itself is an orphan (has no matching open)
+              -- -> put it into mandatory (snd orphans), these are never pruned
+              -- -> this is imo the ugliest thing about this function, but I don't know how to
+              --    solve it nicely
+              True  -> mismatched' restStr (ix+1) (fst ophs, (ix,ix+1):(snd ophs))
+              -- occurence of close deletes the closest open from orphans (strips
+              -- head of orphans because we reversed the occurences in | s==open = ...)
+              False -> mismatched' restStr (ix+1) (tail (fst ophs), snd ophs)
+          -- current char neither open nor close -> not relevant for us
+          | otherwise = mismatched' restStr (ix+1) ophs
+
+
+slicesToFT :: AttrName -> [(Int,Int)] -> [Fontification]
+slicesToFT attrName slices = slicesToFT' slices
+  where slicesToFT' [] = []
+        slicesToFT' (m:ms) = let start = fst m; end = snd m
+                             in (FT start end attrName) : slicesToFT' ms
+
+-- checks if a slice is already contained in a fontification
+isFontified :: (Int,Int) -> [Fontification] -> Bool
+isFontified _ [] = False
+isFontified slice@(start,end) (f:fs)
+  | ftStart f <= start && ftEnd f >= end = True
+  | otherwise = isFontified slice fs