module Checkmate.Parser.IndentBlock
( parser
, parseSourceCode
, parseSourceFile
) where
import Control.Monad
import Data.List
import Data.Range.Range
import Data.Set
import Data.Text
import Data.Text.IO
import Text.Megaparsec
import Text.Megaparsec.Text
import Checkmate.Check
parseSourceFile :: FilePath
-> IO (Either (ParseError (Token Text) Dec) Checklist)
parseSourceFile filePath = do
input <- Data.Text.IO.readFile filePath
return $ parseSourceCode filePath input
parseSourceCode :: FilePath
-> Text
-> Either (ParseError (Token Text) Dec) Checklist
parseSourceCode = parse parser
data Line = CheckComment Text | Line | EmptyLine deriving (Eq, Ord, Show)
parser :: Parser Checklist
parser = do
lines' <- line `sepEndBy` eol
eof
let checkData = analyzeIndents 0 [] lines'
sorted = sort checkData
checks = [ Check (FileBlock path $ mkRange fromTo) i text
| (i, (path, fromTo, _, text)) <- Data.List.zip [1..] sorted
]
return $ Data.Set.fromList checks
where
mkRange :: (Int, Int) -> Range Int
mkRange (from, to)
| from >= to = SingletonRange from
| otherwise = SpanRange from to
indent :: Parser Int
indent = choice
[ tab >> return 8
, char ' ' >> return 1
]
someSpaces :: Parser ()
someSpaces = skipMany $ oneOf " \t"
checkKeyword :: Parser ()
checkKeyword = void $ string "CHECK"
checkThenSpaces :: Parser ()
checkThenSpaces = do
checkKeyword
(char ':' >> someSpaces) <|> skipSome (oneOf " \t")
lineCommentStart :: Parser String
lineCommentStart = choice
[ do { c <- oneOf "#%'"; return [c] }
, string "//"
, string "--"
]
lineCommentCheck :: Parser Text
lineCommentCheck = do
startSeq <- lineCommentStart
someSpaces
checkThenSpaces
chars <- many $ noneOf "\n"
nextLines <- many $ try $ do
void eol
someSpaces
void $ string startSeq
someSpaces
many $ noneOf "\n"
return $ stripEnd $ pack $ Data.List.unlines $ chars : nextLines
blockCommentPairs :: [(String, String)]
blockCommentPairs =
[ ("/*", "*/"), ("{-", "-}"), ("<!--", "-->"), ("<#", "#>")
, ("%{", "%}")
]
blockCommentCheck :: Int -> Parser Text
blockCommentCheck depth =
choice $ fmap (blockComment depth) blockCommentPairs
blockComment :: Int -> (String, String) -> Parser Text
blockComment depth (start, end) = do
void $ string start
linebreaks <- many $ try $ do
skipMany $ oneOf " \t\r"
char '\n'
innerDepth <- many indent
checkThenSpaces
chars <- manyTill anyChar (string end)
let leftPadding = case linebreaks of
[] -> depth
_ -> sum innerDepth
return $ stripEnd $ pack $ stripLeftPadding leftPadding chars
line :: Parser (FilePath, Int, Int, Line)
line = do
SourcePos filePath lineNo _ <- getPosition
widths <- many indent
let depth = sum widths
lineT <- choice
[ try $ fmap CheckComment lineCommentCheck
, try $ CheckComment <$> blockCommentCheck depth
, try (some (noneOf "\n") >> return Line)
, return EmptyLine
]
return (filePath, read . show . unPos $ lineNo, depth, lineT)
stripLeftPadding :: Int -> String -> String
stripLeftPadding width =
Data.List.unlines . fmap (lstrip width) . Data.List.lines
where
lstrip :: Int -> String -> String
lstrip _ [] = []
lstrip 0 txt = txt
lstrip w (' ' : xs) = lstrip (w 1) xs
lstrip w txt@('\t' : xs) = if w >= 8 then lstrip (w 8) xs else txt
lstrip _ txt = txt
analyzeIndents :: Int
-> [(FilePath, (Int, Int), Int, Text)]
-> [(FilePath, Int, Int, Line)]
-> [(FilePath, (Int, Int), Int, Text)]
analyzeIndents _ prev [] = prev
analyzeIndents prevDepth prev ((_, _, _, EmptyLine) : rest) =
analyzeIndents prevDepth prev rest
analyzeIndents prevDepth prev ((filePath, lineNo, depth, lineT) : rest) =
dedented ++ analyzeIndents depth next rest
where
isDedented :: (FilePath, (Int, Int), Int, Text) -> Bool
isDedented (_, _, checkDepth, _) =
prevDepth > depth && checkDepth > depth
(dedented, inScope) = Data.List.partition isDedented prev
next :: [(FilePath, (Int, Int), Int, Text)]
next =
[ (path, (from, lineNo), d, t)
| (path, (from, _), d, t) <- inScope
] ++ case lineT of
CheckComment t -> [(filePath, (lineNo, lineNo), depth, t)]
_ -> []