From 77081e34372fe39ced6b43b655defaa5dcde3061 Mon Sep 17 00:00:00 2001 From: Armin Friedl Date: Fri, 12 Aug 2016 23:06:03 +0200 Subject: [PATCH] beautifications --- src/App/Fontifier.hs | 141 +++++++++++++++++++++++-------------------- 1 file changed, 75 insertions(+), 66 deletions(-) diff --git a/src/App/Fontifier.hs b/src/App/Fontifier.hs index e5ffbc0..b73f40c 100644 --- a/src/App/Fontifier.hs +++ b/src/App/Fontifier.hs @@ -11,23 +11,41 @@ import qualified Text.Regex.TDFA as Tdfa ---- Various ---- import Data.Array import Data.String -import Lens.Micro ((^.), _1, _2) +import Lens.Micro ((^.), _1, _2) {---- Type Definitions ----} -- defines an attribute for a text slice -data Fontification = FT { ftStart :: Int -- start index in string - , ftEnd :: Int -- end index in string - , ftAttr :: AttrName -- attribute name - } deriving (Show) +data Fontification = FT { ftStart :: Int -- start index in string + , ftEnd :: Int -- end index in string + , ftAttr :: AttrName -- attribute name + } deriving (Show) + +type Fontifications = [Fontification] +type Fontifier = (CheckString -> Fontifications) +type Slice = (Int,Int) +type Slices = [Slice] +type MatchResult = [Tdfa.MatchArray] +type CheckString = String +type Regex = Tdfa.Regex + +{---- Infix Operators ----} + +infixl 9 §: +(§:) :: (AttrName -> a) -> String -> a +f §: s = f $ attrName s + +infixl 9 §~ +(§~) :: (Regex -> a) -> String -> a +f §~ s = f $ Tdfa.makeRegex s + +-- reduces precedence of (.) to work +-- more "naturally" in combination with +-- §: / §~ +infixr 8 §. +(§.) :: (b -> c) -> (a -> b) -> a -> c +f §. s = f . s -type Fontifications = [Fontification] -type Fontifier = (CheckString -> Fontifications) -type Slice = (Int,Int) -type Slices = [Slice] -type MatchResult = [Tdfa.MatchArray] -type RegexStr = String -type CheckString = String {---- Functions ----} @@ -60,27 +78,35 @@ concatApply (f:fs) s = f s ++ concatApply fs s + {--- Fontifier ---} - -{-- Regex-Based Fontifier --} - --- TODO: most of the .+ don't actually allow any whitespace-like character --- maybe we should use \w/(:word:) instead? - -- :: CheckString -> Fontifications -assignments = slicesToFT (attrName "assignment") . matchStripCmts "\\**.+=.+;" -guards = slicesToFT (attrName "guard") . matchStripCmts "\\[.+:.+\\]" -returns = slicesToFT (attrName "return") . matchStripCmts "\\^.+;" -strings = slicesToFT (attrName "string") . matchStripCmts "\"[^%]*\"" -comments = slicesToFT (attrName "comment") . matchAll "%.*" + +{- Regex-Based -} + +assignments = slicesToFT §: "assignment" §. matchStripCmts §~ "\\**.+=.+;" +guards = slicesToFT §: "guard" §. matchStripCmts §~ "\\[.+:.+\\]" +returns = slicesToFT §: "return" §. matchStripCmts §~ "\\^.+;" +strings = slicesToFT §: "string" §. matchStripCmts §~ "\"[^%]*\"" +comments = slicesToFT §: "comment" §. matchAll §~ "%.*" -{- Utility Functions (Regex) -} -matchAll :: RegexStr -> CheckString -> Slices -matchAll regexString bs = let regex = Tdfa.makeRegex regexString :: Tdfa.Regex - in matchesToSlices $ Tdfa.matchAll regex bs +{- Custom/Function-Based -} -matchStripCmts :: RegexStr -> CheckString -> Slices +untermStrings = slicesToFT §: "err_unterm" §. unterm §~ "\"[^%]*\"[^\\;]" +untermAssignments s = slicesToFT §: "err_unterm" §. prune (assignments s) $ (unterm §~ "\"[^%]*\"[^\\;]") s +untermReturns s = slicesToFT §: "err_unterm" §. prune (returns s) $ (unterm §~ "\\^[^;%]+[^\\;]") s + +mismatchedBrackets s = concatMap (mismatched §: "err_brackets" $ s) [('(',')'),('[',']'),('{','}')] + +{--- Utility Functions ---} + +{- Regex Utilities -} + +matchAll :: Regex -> CheckString -> Slices +matchAll r s = matchesToSlices $ Tdfa.matchAll r s + +matchStripCmts :: Regex -> CheckString -> Slices matchStripCmts r s = stripComments $ matchAll r s where commentsFts = comments s stripComments [] = [] @@ -94,50 +120,34 @@ matchesToSlices (m:ms) = let match = m ! 0 -- get 1st elem of match array (this in (fst match, (fst match) + (snd match)): matchesToSlices ms - -{-- Custom/Function-Based Fontifier --} - -mismatchedBrackets :: CheckString -> Fontifications -mismatchedBrackets s = concatMap fontifyMismatched pairs - where fontifyMismatched = mismatched (attrName "err_brackets") s - pairs = [('(',')'),('[',']'),('{','}')] +{- Custom Fontifier Utilities -} mismatched :: AttrName -> CheckString -> (Char, Char) -> Fontifications -mismatched attrName s (open, close) = slicesToFT attrName $ (fst orphans)++(snd orphans) -- (fst orphans) = open without close, +mismatched attrName s (open, close) = slicesToFT attrName $ (fst orphans)++(snd orphans) -- (fst orphans) = open without close, where orphans = mismatched' s 0 ([],[]) -- (snd orphans) = close without open checkFts = strings s ++ comments s mismatched' [] _ ophs = ophs mismatched' (curChr:restStr) ix ophs - | isFontified (ix,ix+1) checkFts = mismatched' restStr (ix+1) ophs -- already fontified? -> continue - | curChr == open = mismatched' restStr (ix+1) ((ix, ix+1):(fst ophs), snd ophs) -- open? -> assume orphan until proven otherwise - | curChr == close = case null (fst ophs) of - True -> mismatched' restStr (ix+1) (fst ophs, (ix,ix+1):(snd ophs)) -- close but no orphaned open? -> close is surely an orphan - False -> mismatched' restStr (ix+1) (tail (fst ophs), snd ophs) -- close and ophaned open exists? -> delete nearest orphaned open - | otherwise = mismatched' restStr (ix+1) ophs -- neither open nor close? -> continue + | alreadyFontified = proceedWith ophs + | curChr == open = proceedWith addOrphanedOpen -- assume orphan until proven otherwise + | curChr == close = proceedWith $ if orphanedOpenExists then adoptNearestOpen else addOrphanedClose + | otherwise = proceedWith ophs + -- try just reading the cases, ignore the where + where proceedWith = mismatched' restStr (ix+1) + addOrphanedOpen = ((ix,ix+1):(fst ophs), snd ophs) -- (ix,ix+1) = slice of curChr + addOrphanedClose = (fst ophs, (ix,ix+1):(snd ophs)) + adoptNearestOpen = (tail (fst ophs), snd ophs) -- delete nearest orphaned open + orphanedOpenExists = not $ null (fst ophs) + alreadyFontified = isFontified (ix,ix+1) checkFts - -untermStrings :: CheckString -> Fontifications -untermStrings = let regex = Tdfa.makeRegex ("\"[^%]*\"[^\\;]"::String) :: Tdfa.Regex - in slicesToFT (attrName "err_unterm") . unterm regex - -untermAssignments :: CheckString -> Fontifications -untermAssignments s = let regex = Tdfa.makeRegex ("\\**[^%]+=[^;%]+[^\\;]"::String) :: Tdfa.Regex - in slicesToFT (attrName "err_unterm") . prune (assignments s) $ unterm regex s - -untermReturns :: CheckString -> Fontifications -untermReturns s = let regex = Tdfa.makeRegex ("\\^[^;%]+[^\\;]"::String) :: Tdfa.Regex - in slicesToFT (attrName "err_unterm") . prune (returns s) $ unterm regex s - - -unterm :: Tdfa.Regex -> CheckString -> Slices +unterm :: Regex -> CheckString -> Slices unterm regex s = lastChar untermed where commentsFts = comments s untermed = prune commentsFts $ matchesToSlices $ Tdfa.matchAll regex s mismatchedQuotes :: CheckString -> Fontifications -mismatchedQuotes s = slicesToFT (attrName "err_quotes") $ firstChar untermed - where regex = Tdfa.makeRegex ("\""::String) :: Tdfa.Regex - matchedSlices = matchesToSlices $ Tdfa.matchAll regex s +mismatchedQuotes s = slicesToFT §: "err_quotes" $ firstChar untermed + where matchedSlices = matchesToSlices $ (Tdfa.matchAll §~ "\"") s untermed = let commentsFts = comments s; stringsFts = strings s in negPrune (commentsFts++stringsFts) matchedSlices negPrune _ [] = [] @@ -145,10 +155,10 @@ mismatchedQuotes s = slicesToFT (attrName "err_quotes") $ firstChar untermed | not $ isFontified curSlice checkFts = curSlice: negPrune checkFts slices | otherwise = negPrune checkFts slices - -{-- Utility Functions (General) --} + +{- General Fontification Utilities -} prune :: Fontifications -> Slices -> Slices prune _ [] = [] @@ -168,7 +178,6 @@ firstChar [] = [] firstChar (curSlice:slices) = let start = fst curSlice in (start, start+1): firstChar slices - slicesToFT :: AttrName -> Slices -> Fontifications slicesToFT attrName slices = slicesToFT' slices where slicesToFT' [] = [] @@ -180,13 +189,13 @@ isFontified :: Slice -> Fontifications -> Bool isFontified _ [] = False isFontified slice@(start,end) (f:fs) | ftStart f <= start && ftEnd f >= end = True - | otherwise = isFontified slice fs + | otherwise = isFontified slice fs --- checks if a slice penetrats a fontification +-- checks if a slice penetrates a fontification penetratesFT :: Slice -> Fontifications -> Bool penetratesFT _ [] = False penetratesFT slice@(start,end) (f:fs) | ftStart f <= start && ftEnd f >= end = True -- yummie sandwich | ftStart f >= start && ftStart f <= end = True -- applied backstabbing | ftEnd f <= end && ftEnd f >= start = True -- Et tu, Brute? :( - | otherwise = penetratesFT slice fs + | otherwise = penetratesFT slice fs -- See ya at tha crossroads