scan 0.1.0.7 → 0.1.0.8
raw patch · 3 files changed
+83/−53 lines, 3 files
Files
- scan.cabal +1/−1
- src/Language/Haskell/Scanner.hs +77/−48
- src/scan.hs +5/−4
scan.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.4 build-type: Simple name: scan-version: 0.1.0.7+version: 0.1.0.8 license: BSD3 license-file: doc/LICENSE category: Development
src/Language/Haskell/Scanner.hs view
@@ -62,7 +62,7 @@ -- | a literal enclosed in quotes and a backslash as escape character quotedLit :: Char -> CharParser st String-quotedLit q = enclosedBy (flat $ many $ single (noneOf $ '\\' : [q])+quotedLit q = enclosedBy (flat $ many $ single (noneOf ['\\', q]) <|> char '\\' <:> single anyChar) $ char q -- | text in double quotes@@ -79,18 +79,12 @@ tryString :: String -> CharParser st String tryString = try . string --- | nested comments, open and closing strings must have at least two chars+-- | nested comments, open and closing strings must have at least one char nestedComment :: String -> String -> CharParser st String-nestedComment op cl = case (op, cl) of- (oh : ot : _, ch : ct : _) ->- tryString op <++>- flat (many $ single- (noneOf [oh, ch]- <|> try (char ch << notFollowedBy (char ct))- <|> try (char oh << notFollowedBy (char ot)) <?> "")- <|> nestedComment op cl)- <++> string cl- _ -> error "nestedComment"+nestedComment op cl =+ let inComment = tryString cl+ <|> (nestedComment op cl <|> single anyChar) <++> inComment+ in tryString op <++> inComment -- * haskell tokens @@ -151,9 +145,12 @@ showQualName :: QualName -> String showQualName (Name _ _ s) = s +isLetterOrUnderscore :: Char -> Bool+isLetterOrUnderscore c = c == '_' || isLetter c+ -- | the possible characters starting a name qIdStart :: Parser Char-qIdStart = satisfy $ \ c -> c == '_' || isLetter c || opSym c+qIdStart = satisfy $ \ c -> isLetterOrUnderscore c || opSym c -- | any quoted, qualified, or unqualified name or operator qId :: Parser QualName@@ -167,7 +164,7 @@ return $ Name True k $ n ++ d : r <|> do let noCh = notFollowedBy (char '\'')- s <- try (string "'" << lookAhead (letter << noCh)) -- limited recognition+ s <- try (string "'" << lookAhead (satisfy isLetterOrUnderscore >> noCh)) <|> try (string "''" << noCh) Name b k r <- qId return $ Name b k $ s ++ r@@ -188,6 +185,8 @@ | Infix -- ^ something in back quotes | Sep -- ^ a separator | Indent -- ^ a newline or nothing at the very beginning+ | QuasiQuote -- ^ a quasi-quote+ | ThQuote -- ^ a possible template haskell quotation -- | the data type for tokens data Token@@ -214,10 +213,21 @@ charLit <++> optH <|> (stringLit <|> number) <++> optionL (char '#' <:> optH) +-- | the template haskell quasi-quotes+quasiQuote :: Parser Token+quasiQuote = try $ do+ q <- char '[' >> lId << char '|'+ let start = '[' : q ++ "|"+ -- check for plain TH quotation+ if elem q $ single "dept" then return $ Token ThQuote start else+ fmap (Token QuasiQuote . (start ++) . (++ "|]"))+ $ manyTill anyChar $ tryString "|]"+ -- | parse any non-white token tok :: Parser Token tok = fmap (Token BlockComment) nestComment <|> fmap (Token LineComment) lineComment+ <|> quasiQuote <|> fmap QualName qId <|> fmap (Token Sep) (single $ oneOf seps) <|> fmap (Token Indent) (string "\n")@@ -332,8 +342,8 @@ rmSp (PosTok p t _) = PosTok p t "" topKeys :: [String]-topKeys = ["import", "data", "newtype", "type", "class", "instance"]--- "module" may occur in export lists!+topKeys = ["import", "data", "newtype", "class", "instance"]+-- "module" may occur in export lists, "type" within type families! layoutKeys :: [String] layoutKeys = ["do", "of", "where"]@@ -358,11 +368,17 @@ -> (bTok, [diag | n > 1]) _ -> (PosTok p t $ take m w, [diag | n > m]) +-- | cut of initial line comment marker and spaces+trim2 :: String -> String+trim2 = dropWhile isSpace . drop 2++-- | add two dashes to a string plus a space for a non-emtpy string+addLineCommentMark :: String -> String+addLineCommentMark r = "--" ++ if null r then r else ' ' : r+ -- | tidy up line comments adjustLineComment :: String -> String-adjustLineComment s = -- cut of initial line comment marker and spaces- let r = dropWhile isSpace $ drop 2 s in- "--" ++ if null r then r else ' ' : r+adjustLineComment = addLineCommentMark . trim2 -- | check if prefix extended by one char from next string is still a prefix hasLongerPrefix :: String -> String -> String -> Bool@@ -394,9 +410,10 @@ -- * analyse and adjust lines -anaPosTok :: PosTok -> (PosTok, [Diag])-anaPosTok t@(PosTok p u w) = case u of- Token BlockComment s -> let+anaPosTok :: Opts -> PosTok -> (PosTok, [Diag])+anaPosTok opts t@(PosTok p u w) =+ let cC = checkComments opts in case u of+ Token BlockComment s | cC -> let n = adjustComment s s5 = take 5 s nr = take 5 $ reverse n@@ -406,7 +423,7 @@ ++ [ Diag p "avoid nested comments" | isInfixOf "{-" $ drop 2 s ] ++ [ Diag (updatePosString p s) $ "non-conventional comment end: " ++ reverse sr | sr /= nr ])- Token LineComment s -> let+ Token LineComment s | cC -> let n = adjustLineComment s s4 = take 4 s sr = takeWhile isPrint $ dropWhile isSpace $ drop 2 s4@@ -421,22 +438,29 @@ | isInfixOf "{-" n ] ++ [ Diag q "line comment contains block comment end" | isInfixOf "-}" n ])+ Token ThQuote s | not $ tempHask opts -> let+ (f, r) = splitAt 2 s+ in (PosTok p (Token ThQuote $ f ++ " |") w,+ [ Diag (updatePosString p f) $ "put blank between " ++ f ++ " and |"+ | r == "|" ]) _ -> (t, [ Diag p "use layout instead of ;" | isSepIn ";" u ]) -- | a comment string that is no pragma or directive isNormalCommentString :: String -> Bool-isNormalCommentString s = elem (drop 2 $ take 3 s) [" ", "\n"]+isNormalCommentString s = case drop 2 s of+ c : _ -> notElem c "!#"+ _ -> True -- | a comment that is no pragma or directive-isNormalComment :: PosTok -> Bool-isNormalComment p@(PosTok _ u _) =- isComment u && isNormalCommentString (showPosTok $ fst $ anaPosTok p)+isNormalComment :: Token -> Bool+isNormalComment u =+ isComment u && isNormalCommentString (showToken u) -- | check if no other normal comment follows noOtherComment :: [PosTok] -> Bool noOtherComment ps = case ps of [] -> True- p : _ -> not $ isNormalComment p+ PosTok _ u _ : _ -> not $ isNormalComment u -- | the data type for options passed to the analysis data Opts = Opts@@ -449,7 +473,7 @@ , noMultBlanksAfter :: Token -> Bool , makeLineComments :: Bool , joinComments :: Bool- , ignoreComments :: Bool+ , checkComments :: Bool , commentGap :: Int , checkSpacing :: Bool }@@ -466,18 +490,17 @@ , noMultBlanksAfter = isKeyw $ "let" : layoutKeys , makeLineComments = True , joinComments = True- , ignoreComments = False+ , checkComments = True , commentGap = 0 , checkSpacing = True } -- | analyse consecutive tokens anaPosToks :: Opts -> [PosTok] -> ([PosTok], [Diag])-anaPosToks opts l = let ignoreC = ignoreComments opts in case l of+anaPosToks opts l = case l of [] -> ([], []) t0 : r1 ->- let (tC@(PosTok p1 u1 w1), cC) = anaPosTok t0- (t1, cs) = if ignoreC then (t0, []) else (tC, cC)+ let (t1@(PosTok p1 u1 w1), cs) = anaPosTok opts t0 in case r1 of [] -> ([t1], cs) t2@(PosTok p2 u2 w2) : r2 -> let@@ -516,31 +539,37 @@ omitSpace = checkS && o1 && (isInfixOp u2 || c2) || isInfixOp u1 && c2 && not (isSymb [".."] u1 && isSepIn "]" u2) addSpace = checkS && ni1 && nw1- && (not (o1 || isSymb (map (: []) "!#-@~") u1) || isComment u2)+ && (not (o1 || isSymb (single "!#-@~") u1) || isComment u2) && spaceNeededBefore u2 && if tempHask opts then not $ isSymb ["$"] u1 else True- s1C = take (length s1 - 3) s1+ trim = reverse . trim2+ s1C = trim $ trim s1 in case r2 of- _ | makeLineComments opts && isComment u1 && isIndent u2- && noOtherComment r2 && isPrefixOf "{- " s1C- && not (any (== '\n') s1C)- -> ( PosTok p1 (Token LineComment $ "-- " ++ drop 3 s1C) "" : ar1+ _ | makeLineComments opts && isNormalComment u1 && isIndent u2+ && noOtherComment r2 && noLineComment u1+ && notElem '\n' s1C+ -> ( PosTok p1 (Token LineComment $ addLineCommentMark s1C) "" : ar1 , cs ++ Diag p1 "could be a line comment" : rds)- | joinC && isNormalComment tC && isNormalComment t2+ | joinC && isNormalComment u1 && isNormalComment u2 -> (al, cs ++ Diag p2 "consecutive comments" : rds) t3@(PosTok _ u3 _) : r3- | joinC && isNormalComment tC && isIndent u2 && isNormalComment t3- -> let (PosTok p3 nu3 w3, cs3) = anaPosTok t3- (f3, h3) = splitAt 3 (showToken nu3)+ | joinC && isNormalComment u1 && isIndent u2 && isNormalComment u3+ -> let (PosTok p3 nu3 w3, cs3) = anaPosTok opts t3+ su3 = showToken nu3+ h3 = trim2 su3+ f3 = take (length su3 - length h3) su3 hh3 = head h3- isHaddockStart = not (null h3) && any (hh3 ==) "$*^|"+ cC = checkComments opts+ isHaddockStart = cC && not (null h3)+ && elem hh3 "$*^|" s3 = if isHaddockStart then dropWhile isSpace $ if hh3 == '*' then dropWhile (== '*') h3 else tail h3- else h3+ else if cC then h3 else drop 2 su3 nt3 = PosTok p1 (Token BlockComment- $ (if noLineComment u1 then s1C- else "{- " ++ drop 3 s1)+ $ (if noLineComment u1+ then reverse . dropWhile (== ' ') . drop 2 $ reverse s1+ else "{-" ++ drop 2 s1) ++ w1 ++ s2 ++ w2 ++ replicate (commentGap opts) ' ' ++ if noLineComment nu3 then s3 else s3 ++ " -}") w3@@ -550,7 +579,7 @@ : [ Diag (updatePosString p3 f3) $ "unexpected haddock marker " ++ [hh3] | isHaddockStart ]- ++ (if ignoreC then [] else cs3) ++ rds3)+ ++ cs3 ++ rds3) | checkS && isFstInfixMinusArg u1 && isSymb ["-"] u2 && spaceNeededBefore u3 -> let (bt2, m2) = multipleBlanks opts u3 t2 in
src/scan.hs view
@@ -35,7 +35,7 @@ -- | the hard-coded version string. version :: String-version = "scan-0.1.0.7 http://projects.haskell.org/style-scanner/"+version = "scan-0.1.0.8 http://projects.haskell.org/style-scanner/" data Flag = Help@@ -128,7 +128,7 @@ else m { maxBlanks = n } CheckSpacing b -> m { checkSpacing = b }- CheckComments b -> m { ignoreComments = not b }+ CheckComments b -> m { checkComments = b } MakeLineComments b -> m { makeLineComments = b } JoinComments b -> m { joinComments = b } CommentGap n -> m { commentGap = n }@@ -236,9 +236,10 @@ checkBlankLines f m c n l = let p = diagLinePos f n in case l of [] -> [Diag p $ "trailing (" ++ show c ++ ") blank lines" | c > 0] s : r -> let n1 = n + 1 in- if null $ filter (not . isSpace) s then checkBlankLines f m (c + 1) n1 r- else [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines"+ if any (not . isSpace) s+ then [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines" | c > m ] ++ checkBlankLines f m 0 n1 r+ else checkBlankLines f m (c + 1) n1 r -- | removing more than two consecutive lists fulfilling the predicate removeBlankLines :: Int -> Int -> ([a] -> Bool) -> [[a]] -> [[a]]