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

unterminated strings, unmatched brackets, assignments

Browse source
This commit is contained in:
Armin Friedl 2016-08-12 03:38:45 +02:00
parent 559a302f7f
commit c7a83b731c
1 changed files with 106 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

129
src/App/Fontifier.hs
View file

@ -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" "\\[.+:.+\\]"
@ -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)
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