beautifications
This commit is contained in:
Armin Friedl
parent
e9aaddc974
commit
77081e3437
1 changed files with 75 additions and 66 deletions
|
|
@ -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,13 +120,7 @@ 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,
|
||||
|
|
@ -108,36 +128,26 @@ mismatched attrName s (open, close) = slicesToFT attrName $ (fst orphans)++(snd
|
|||
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 _ [] = []
|
||||
|
|
@ -148,7 +158,7 @@ mismatchedQuotes s = slicesToFT (attrName "err_quotes") $ firstChar untermed
|
|||
|
||||
|
||||
|
||||
{-- 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' [] = []
|
||||
|
|
@ -182,11 +191,11 @@ isFontified slice@(start,end) (f:fs)
|
|||
| ftStart f <= start && ftEnd f >= end = True
|
||||
| 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue