scan 0.1.0.2 → 0.1.0.3
raw patch · 3 files changed
+164/−176 lines, 3 filesdep ~parsec
Dependency ranges changed: parsec
Files
- scan.cabal +3/−3
- src/Language/Haskell/Scanner.hs +88/−143
- src/scan.hs +73/−30
scan.cabal view
@@ -1,7 +1,7 @@-cabal-version: >= 1.6+cabal-version: >= 1.4 build-type: Simple name: scan-version: 0.1.0.2+version: 0.1.0.3 license: BSD3 license-file: doc/LICENSE category: Development@@ -17,7 +17,7 @@ stability: experimental executable scan- build-depends: base < 5, parsec < 3 || >= 3+ build-depends: base < 5, parsec < 3 hs-source-dirs: src main-is: scan.hs other-modules: Language.Haskell.Scanner
src/Language/Haskell/Scanner.hs view
@@ -14,11 +14,9 @@ -} module Language.Haskell.Scanner- ( splitLines- , splitBy+ ( scan , showScan , processScan- , scan , PosTok , Diag (..) , showDiag@@ -174,27 +172,29 @@ infixOp :: Parser String infixOp = enclosedBy (fmap showQualName qId) $ char '`' --- | the separators are newline, comma, semicolon and three kinds of parens+-- | the separators are comma, semicolon and three kinds of parens seps :: String-seps = "[({,;})]\n"+seps = "[({,;})]" -- | beside names and separators we have a couple of more token kinds-data TokenKind = LineComment | BlockComment | Literal | Infix+data TokenKind =+ LineComment -- ^ a line comment+ | BlockComment -- ^ single- or multiline (nested) block comment+ | Literal -- ^ number, character, or string+ | Infix -- ^ something in back quotes+ | Sep -- ^ a separator+ | Indent -- ^ a newline or nothing at the very beginning -- | the data type for tokens data Token = QualName QualName- | Sep Char | Token TokenKind String- | Start -- ^ the void token at the very beginning -- | renders the original string without kind information showToken :: Token -> String showToken t = case t of QualName q -> showQualName q- Sep c -> [c] Token _ s -> s- Start -> "" -- | all white spaces except newline isWhite :: Char -> Bool@@ -215,7 +215,8 @@ tok = fmap (Token BlockComment) nestComment <|> fmap (Token LineComment) lineComment <|> fmap QualName qId- <|> fmap Sep (oneOf seps)+ <|> fmap (Token Sep) (single $ oneOf seps)+ <|> fmap (Token Indent) (string "\n") <|> fmap (Token Literal) literal <|> fmap (Token Infix) infixOp @@ -239,32 +240,12 @@ -- | the initial 'white' stuff startTok :: Parser PosTok-startTok = fmap (PosTok startPos Start) white+startTok = fmap (PosTok startPos $ Token Indent "") white -- | the final scanner scan :: Parser [PosTok] scan = startTok <:> many posTok << eof --- * splitting and removing--{- | a generic splitting function that keeps the separator as first element-except in the first list. -}-splitBy :: (a -> Bool) -> [a] -> [[a]]-splitBy p l = let (fr, rt) = break p l in fr : case rt of- [] -> []- d : tl -> let hd : tll = splitBy p tl in (d : hd) : tll---- | removing more than two consecutive lists fulfilling the predicate-removeBlankLines :: Int -> ([a] -> Bool) -> [[a]] -> [[a]]-removeBlankLines c p l = case l of- [] -> []- x : r ->- if p x- then if c > 1- then removeBlankLines c p r- else x : removeBlankLines (c + 1) p r- else x : removeBlankLines 0 p r- -- * message data type -- | messages with positions@@ -300,14 +281,13 @@ isSepIn :: String -> Token -> Bool isSepIn cs t = case t of- Sep c -> elem c cs+ Token Sep [c] -> elem c cs _ -> False isIndent :: Token -> Bool-isIndent = isSepIn "\n"--isLineBreak :: PosTok -> Bool-isLineBreak (PosTok _ t _) = isIndent t+isIndent t = case t of+ Token Indent _ -> True+ _ -> False isOpPar :: Token -> Bool isOpPar = isSepIn "[({"@@ -329,34 +309,27 @@ QualName (Name _ k _) -> case k of Sym -> False _ -> True- Sep _ -> isClPar t Token k _ -> case k of Literal -> True Infix -> True+ Sep -> isClPar t _ -> False- Start -> False +isSymb :: [String] -> Token -> Bool+isSymb s t = case t of+ QualName (Name False Sym r) -> elem r s+ _ -> False+ noSpaceNeededBefore :: Token -> Bool noSpaceNeededBefore t =- isSepIn ",;})]" t || showToken t == "@"+ isSepIn ",;})]" t || isIndent t || isSymb ["-", "@"] t noSpaceNeededAfter :: Token -> Bool noSpaceNeededAfter t =- isOpPar t || elem (showToken t) (map (: []) "!#-@~")+ isOpPar t || isIndent t || isSymb (map (: []) "!#-@~") t -- * adjusting tokens --- | replace all white spaces by blanks-untabify :: SourcePos -> String -> String-untabify p s =- let p2 = updatePosString p s- bs = sourceColumn p2 - sourceColumn p- in replicate bs ' '--untab :: PosTok -> PosTok-untab (PosTok p t w) =- PosTok p t $ untabify (updatePosString p $ showToken t) w- -- | remove trailing spaces rmSp :: PosTok -> PosTok rmSp (PosTok p t _) = PosTok p t ""@@ -366,16 +339,17 @@ blank (PosTok p t _) = PosTok p t " " multipleBlanks :: PosTok -> [Diag]-multipleBlanks (PosTok p t w) = let n = length w in- [ Diag (updatePosString p $ showToken t)- $ "multiple (" ++ show n ++ ") blanks"- | n > 1 ]+multipleBlanks (PosTok p t w) =+ let q = updatePosString p $ showToken t+ n = length w+ in [ Diag q $ "up to column " ++ show (sourceColumn q + n)+ ++ " multiple (" ++ show n ++ ") blanks" | n > 1 ] -- | tidy up line comments adjustLineComment :: String -> String-adjustLineComment = ("--" ++)- . reverse . dropWhile isSpace . reverse- . (' ' :) . dropWhile isSpace . drop 2 -- cut of initial line comment marker+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 -- | check if prefix extended by one char from next string is still a prefix hasLongerPrefix :: String -> String -> String -> Bool@@ -397,10 +371,7 @@ adjustBothEnds :: String -> String -> String -> String -> String adjustBothEnds p q n s = if hasLongerPrefix p n s then s else- concatMap (reverse . dropWhile isWhite . reverse)- $ removeBlankLines 0 (all isSpace)- $ splitBy (== '\n')- $ reverse $ adjustPrefix (reverse q) n $ reverse $ adjustPrefix p n s+ reverse $ adjustPrefix (reverse q) n $ reverse $ adjustPrefix p n s -- | adjust a block comment adjustComment :: String -> String@@ -410,12 +381,6 @@ -- * analyse and adjust lines --- | utility to combine results-(<+>) :: (PosTok, [Diag]) -> ([PosTok], [Diag]) -> ([PosTok], [Diag])-(t, ds) <+> (ts, es) = (t : ts, ds ++ es)--infixr 4 <+>- anaPosTok :: PosTok -> (PosTok, [Diag]) anaPosTok t@(PosTok p u w) = case u of Token BlockComment s -> let@@ -427,106 +392,86 @@ [ Diag p $ "non-conventional comment start: " ++ s5 | s5 /= take 5 n ] ++ [ Diag (updatePosString p s) $ "non-conventional comment end: " ++ reverse sr | sr /= nr ])- _ | showToken u == ";" -> (t, [Diag p "use layout instead of ;"])- _ -> (t, [])+ Token LineComment s -> let+ n = adjustLineComment s+ s4 = take 4 s+ sr = takeWhile isPrint $ dropWhile isSpace $ drop 2 s4+ q = incSourceColumn p 2+ in (PosTok p (Token LineComment n) "",+ [ Diag q $ "put " ++ (if null sr then "only " else "")+ ++ "one blank after --"+ ++ if null sr then "" else " in --" ++ sr+ | s4 /= take 4 n ]+ ++ [ Diag q "missing comment after --" | n == "--" ])+ _ -> (t, [ Diag p "use layout instead of ;" | isSepIn ";" u ]) anaLine :: [PosTok] -> ([PosTok], [Diag]) anaLine l = case l of [] -> ([], []) t0 : r1 -> let (t1@(PosTok p1 u1 w1), cs) = anaPosTok t0 in case r1 of- [] -> case u1 of- Token LineComment s -> let- n = adjustLineComment s- s4 = take 4 s- in ([PosTok p1 (Token LineComment n) ""], cs ++- [Diag p1 $ "leave a single blank after line comment sign: " ++ s4- | s4 /= take 4 n])- _ -> ([rmSp t1], cs ++ [Diag p1 "trailing white space" | not (null w1)])- t2@(PosTok p2 u2 w2) : r2 -> case u1 of- Start -> (rmSp t1, cs ++ [Diag p1 "leading white space" | not (null w1)])- <+> anaLine r1- _ | isIndent u1 -> let (ft, rt) = span (== ' ') w1 in- (untab t1, cs ++- [ Diag (updatePosString p1 ft) "use only blanks for indentation"- | not (null rt) ]) <+> anaLine r1- _ -> let+ [] -> ([t1], cs)+ t2@(PosTok p2 u2 w2) : r2 -> let+ (ar1, rds) = anaLine r1 s1 = showToken u1 s2 = showToken u2+ i1 = isInfixOp u1+ i2 = isInfixOp u2 n1 = length s1 n2 = length s2 lt = n1 <= n2 both = s1 ++ s2+ nw1 = null w1+ bt1 = blank t1+ m1 = multipleBlanks t1 after = case () of _ | isNonPar u1 -> True | isOpPar u2 -> False- | s1 == "\\" -> True- | isInfixOp u1 -> if isInfixOp u2 then lt else True- | isInfixOp u2 || s2 == ".." -> False+ | isSymb ["\\"] u1 -> True+ | i1 -> if i2 then lt else True+ | i2 || isSymb [".."] u2 -> False _ -> lt parsOfBoth = filter (`elem` "[({})]") both- pos = case both of+ pos = case parsOfBoth of _ : _ : _ -> "between" _ | isOpPar u1 -> "after" | isClPar u2 -> "before" _ -> "here" omitSpace = isOpParOrInfix u1 && isClParOrInfix u2- && not (isInfixOp u1 && isInfixOp u2)- && (s1 /= ".." || s2 /= "]")+ && not (i1 && i2)+ && (not (isSymb [".."] u1) || not (isSepIn "]" u2)) addSpace = not (noSpaceNeededAfter u1) && not (noSpaceNeededBefore u2)- (newT1, ds) =- if null w1- then if addSpace- then (blank t1, Diag p2- ("leave space " ++- if after then "after " ++ s1 else "before " ++ s2)- : [ Diag p1 $ "may be template haskell " ++ both- | s1 == "$" ])- else (t1, [])- else if omitSpace- then (rmSp t1,- [Diag p2 $ "no space needed " ++ pos ++ " " ++ parsOfBoth])- else if isComment u2- then (untab t1, [])- else (blank t1, multipleBlanks t1)- pt0 = (newT1, cs ++ ds)- in case r2 of- [] -> pt0 <+> anaLine r1- PosTok _ u3 _ : _ -> let- s3 = showToken u3- ms = [Diag p2 "put spaces around infix -" | null w1 || null w2 ]- ++ multipleBlanks t1 ++ multipleBlanks t2- in if s2 == "-" && not (noSpaceNeededBefore u3)- && isFstInfixMinusArg u1- then (blank t1, cs ++ ms) <+> anaLine (blank t2 : r2)- else (if elem s2 ["do", "of"] && s3 /= "{" && noLineComment u3- then (newT1,- cs ++ Diag p2 ("break line after " ++ show s2) : ds)- else pt0) <+> anaLine r1---- * ensure final newline--isBlankLine :: [PosTok] -> Bool-isBlankLine x = case x of- [PosTok _ Start _] -> True- [t] -> isLineBreak t- _ -> False--removeFinalBlankLines :: [[PosTok]] -> [[PosTok]]-removeFinalBlankLines ll = reverse $ [PosTok startPos (Sep '\n') ""]- : dropWhile isBlankLine (reverse ll)+ in case u1 of+ Token BlockComment s | isIndent u2 -> (t1 : ar1, cs +++ [ Diag p1 "could be a line comment"+ | isPrefixOf "{- " s && not (any (== '\n') s) ] ++ rds)+ _ | nw1 && addSpace -> (bt1 : ar1, cs +++ Diag p2 ("put blank " +++ if after then "after " ++ s1 else "before " ++ s2)+ : [ Diag p1 $ "may be template haskell " ++ both+ | isSymb ["$"] u1 ] ++ rds)+ _ | isIndent u1 || isComment u2 -> (t1 : ar1, cs ++ rds)+ _ | not nw1 && omitSpace -> (rmSp t1 : ar1, cs +++ Diag p2 ("no space needed " ++ pos ++ " " ++ parsOfBoth) : rds)+ _ -> case r2 of+ PosTok _ u3 _ : _+ | isSymb ["-"] u2 && not (noSpaceNeededBefore u3)+ && isFstInfixMinusArg u1 ->+ (bt1 : blank t2 : tail ar1, cs ++ m1 +++ [ Diag p2 "put blanks around infix -" | nw1 || null w2 ]+ ++ multipleBlanks t2 ++ rds)+ | elem s2 ["do", "of"] && not (isSepIn "{" u3)+ && noLineComment u3 && not (isIndent u3) ->+ (bt1 : ar1, cs ++ m1 +++ Diag p2 ("break line after " ++ show s2) : rds)+ _ -> ((if nw1 then t1 else bt1) : ar1, cs ++ m1 ++ rds) -- * main functions --- | split lines at newline tokens-splitLines :: [PosTok] -> [[PosTok]]-splitLines = splitBy isLineBreak- -- | create adjusted source file-processScan :: [[PosTok]] -> String-processScan = concatMap (concatMap showPosTok . fst . anaLine)- . removeBlankLines 1 isBlankLine . removeFinalBlankLines+processScan :: [PosTok] -> String+processScan = concatMap showPosTok . fst . anaLine -- | list all diagnostics-showScan :: [[PosTok]] -> [Diag]-showScan = concatMap (snd . anaLine)+showScan :: [PosTok] -> [Diag]+showScan = snd . anaLine
src/scan.hs view
@@ -13,8 +13,6 @@ module Main () where -import Control.Monad- import Data.Char import Data.List @@ -32,7 +30,7 @@ -- | the hard-coded version string. version :: String-version = "scan-0.1.0.2 http://projects.haskell.org/style-scanner/"+version = "scan-0.1.0.3 http://projects.haskell.org/style-scanner/" -- | the usage string usage :: String@@ -46,7 +44,8 @@ main = do args <- getArgs let (optsOrFiles, files1) = span (/= "--") args- (opts, files2) = partition (isPrefixOf "-") optsOrFiles+ (opts, files2) = partition+ (\ arg -> isPrefixOf "-" arg || all isDigit arg) optsOrFiles files = files2 ++ drop 1 files1 case opts of [] -> case files of@@ -64,15 +63,25 @@ process b f = do str <- readFile f let ls = lines str- cs = concatMap (checkLine f) (zip [1 ..] ls)- ++ checkBlankLines f 1 1 ls- ++ [ Diag (diagLinePos f (length ls)) "missing final newline"- | not $ isSuffixOf "\n" str ]+ wcsr = map (checkLine f) (zip [1 ..] ls)+ wcs = map fst wcsr+ wfile = [ Diag (diagLinePos f 2) "windows (CRLF) file" ]+ noNL = not $ isSuffixOf "\n" str+ cs = case group $ map fst wcs of+ [True : _, [False]] | noNL -> wfile -- with missing newline+ x : _ : _ ->+ [ Diag (diagLinePos f (length x + 1))+ "inconsistent unix (LF) or windows (CRLF) file" ]+ [True : _] -> wfile+ _ -> []+ ++ concatMap snd wcs ++ checkBlankLines f 0 0 ls+ newStr = unlines $ map snd wcsr+ fs = [ Diag (diagLinePos f $ length ls) "missing final newline" | noNL ] prDiags = mapM_ (putStrLn . showDiag)- case parse scan f str of- Right ts -> let x = splitLines ts in- if b then let ds = showScan x in prDiags $ cs ++ ds else- let rstr = processScan x in+ case parse scan f newStr of+ Right x ->+ if b then let ds = showScan x in prDiags $ cs ++ ds ++ fs else+ let rstr = unlines . removeBlankLines 0 null . lines $ processScan x in if rstr == str then putStrLn $ "no changes in \"" ++ f ++ "\"" else do writeFile (f ++ ".bak") str writeFile f rstr@@ -90,34 +99,52 @@ (errorMessages err) -- | check for more than two consecutive lines-checkBlankLines :: FilePath -> Int -> Int -> [String] -> [Diag]-checkBlankLines f c n l = let p = diagLinePos f in case l of- [] -> [Diag (p (n - 1)) "trailing blank lines" | c > 0]+checkBlankLines :: FilePath+ -> Int -- ^ current number of blank lines+ -> Int -- ^ current line number+ -> [String] -> [Diag]+checkBlankLines f 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- if c >= 2 then- Diag (p n) "too many consecutive blank lines"- : checkBlankLines f (- 20) n1 r- else checkBlankLines f (c + 1) n1 r- else checkBlankLines f 0 n1 r+ if null $ filter (not . isSpace) s then checkBlankLines f (c + 1) n1 r+ else [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines"+ | c > 2 ] ++ checkBlankLines f 0 n1 r +-- | removing more than two consecutive lists fulfilling the predicate+removeBlankLines :: Int -> ([a] -> Bool) -> [[a]] -> [[a]]+removeBlankLines c p l = case l of+ [] -> []+ x : r ->+ if p x+ then removeBlankLines (c + 1) p r+ else replicate (min 2 c) [] ++ x : removeBlankLines 0 p r+ -- | create a position from a file and a line number diagLinePos :: FilePath -> Int -> SourcePos diagLinePos = setSourceLine . initialPos -- | check length, chars and end of a line-checkLine :: FilePath -> (Int, String) -> [Diag]+checkLine :: FilePath -> (Int, String) -> ((Bool, [Diag]), String) checkLine f (n, s) = let r = reverse s- rt = dropWhile isSpace r- l = length rt- trailBSlash = takeWhile (== '\\') rt+ (sps, rt) = span isSpace r+ (w, ws) = case sps of+ '\r' : rs -> (True, rs)+ _ -> (False, sps)+ t = reverse rt p = diagLinePos f n- in [Diag p $ "too long line (" ++ show l ++ " chars)" | l > 80]- ++ badChars p s- ++ [Diag (updatePosString p $ init s)+ v = untabify p t+ l = length v+ trailBSlash = takeWhile (== '\\') rt+ in ((w,+ [ Diag p $ "too long line (" ++ show l ++ " chars)" | l > 80 ]+ ++ badChars p t+ ++ [ Diag (setSourceColumn p l) "back slash at line end (may disturb cpp)"- | not (null trailBSlash)]+ | not (null trailBSlash) ]+ ++ [ Diag (setSourceColumn p $ l + 1)+ $ "trailing (" ++ show (length ws) ++ ") white space"+ | not (null ws) ]), v) -- | create diagnostics for bad characters in a line badChars :: SourcePos -> String -> [Diag]@@ -125,5 +152,21 @@ let h : r = splitBy (\ c -> not $ isAscii c && isPrint c) s in snd $ mapAccumL (\ q t@(f : _) -> (updatePosString q t, Diag (updatePosChar q f)- $ "undesirable character: " ++ show f))+ $ "undesirable character " ++ show f)) (updatePosString p h) r++{- | a generic splitting function that keeps the separator as first element+except in the first list. -}+splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy p l = let (fr, rt) = break p l in fr : case rt of+ [] -> []+ d : tl -> let hd : tll = splitBy p tl in (d : hd) : tll++-- | replace all tabs by blanks in a string+untabify :: SourcePos -> String -> String+untabify p s = case s of+ "" -> ""+ c : r -> let q = updatePosChar p c in case c of+ '\t' -> replicate (sourceColumn q - sourceColumn p) ' '+ _ -> [c]+ ++ untabify q r