From c7a83b731c818b2d6e7864a568afdebc5b80d13b Mon Sep 17 00:00:00 2001 From: Armin Friedl Date: Fri, 12 Aug 2016 03:38:45 +0200 Subject: [PATCH] unterminated strings, unmatched brackets, assignments --- src/App/Fontifier.hs | 133 ++++++++++++++++++++++++++++++++++--------- 1 file changed, 106 insertions(+), 27 deletions(-) diff --git a/src/App/Fontifier.hs b/src/App/Fontifier.hs index b20f197..58c2b84 100644 --- a/src/App/Fontifier.hs +++ b/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.Util (bg, fg) -import qualified Graphics.Vty as Vty +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 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) - , (attrName "return" , fg Vty.green) - , (attrName "guard" , fg Vty.yellow) - , (attrName "comment" , fg Vty.magenta) - , (attrName "string" , 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.magenta) + , (attrName "string" , fg Vty.green) + , (attrName "err_brackets" , bg Vty.red) -- unbalanced brackets + , (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 --- fontification functions must take an IsString +-- and returns a list of attributes for text slices. +-- 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, --- the last function has the highest precedence --- can be useful to make e.g. comments "stronger" than strings --- a string in a comment is then fontified as comment +-- all previous ones in case more than one matches for a slice. +-- The last function has the highest precedence. +-- This can be useful to make e.g. comments "stronger" than strings: +-- 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" "\\[.+:.+\\]" @@ -70,9 +95,12 @@ 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) - in FT {ftStart = start, ftEnd = end, ftAttr = attrName} : matchToFT' ms + end = (fst match) + (snd match) + 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