scan 0.1.0.0 → 0.1.0.1
raw patch · 3 files changed
+513/−27 lines, 3 files
Files
- scan.cabal +4/−26
- src/Language/Haskell/Scanner.hs +508/−0
- src/scan.hs +1/−1
scan.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: scan-version: 0.1.0.0+version: 0.1.0.1 license: BSD3 license-file: doc/LICENSE category: Development@@ -10,31 +10,8 @@ copyright: Christian Maeder 2010 synopsis: lexical style suggestions for source code description:- scan checks the format of your source code. It reports- (and partly repairs if given the @-@ option):-- non-ascii characters,- tabs or carriage returns,- trailing white spaces,- backslash at line end,- unconventional comment delimiters,- too long lines,- too many consecutive blank lines,- not a single blank between tokens,- not a single final newline,- no spaces after commas,- spaces between parens and infix operators in sections,- bad layout (wrt @do@ or @of@).-- It may be useful in conjunction with- <http://community.haskell.org/~ndm/hlint/>- to give suggestions on how to improve your source code.-- Repairing is not suited for slices (aka @$(...)@) in template haskell or if- you like to align your code at @=@ or @->@ in the middle of a line (thus- wanting multiple blanks). Furthermore layout may be destroyed by inserting- or deleting blanks, but this is an indication for improving layout anyway.- Also lines may become too long after inserting blanks.+ scan checks the format of your haskell source code regarding:+ comments, white spaces and line breaks. homepage: http://projects.haskell.org/style-scanner stability: experimental@@ -43,5 +20,6 @@ build-depends: base < 5, parsec < 3 || >= 3 hs-source-dirs: src main-is: scan.hs+ other-modules: Language.Haskell.Scanner ghc-options: -Wall
+ src/Language/Haskell/Scanner.hs view
@@ -0,0 +1,508 @@+{- |+Module : $Header$+Description : scan tokens of Haskell sources+Copyright : (c) C. Maeder 2010+License : BSD++Maintainer : chr.maeder@web.de+Stability : provisional+Portability : portable++using parsec as scanner to tokenize haskell sources+and check the spacing++-}++module Language.Haskell.Scanner+ ( splitLines+ , showScan+ , processScan+ , scan+ , PosTok+ ) where++import Control.Monad++import Data.Char+import Data.List++import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Pos++-- * monad shortcuts++infixl 1 <<++(<<) :: Monad m => m a -> m b -> m a+(<<) = liftM2 const++infixr 5 <:>++(<:>) :: Monad m => m a -> m [a] -> m [a]+(<:>) = liftM2 (:)++infixr 5 <++>++(<++>) :: Monad m => m [a] -> m [a] -> m [a]+(<++>) = liftM2 (++)++single :: Monad m => m a -> m [a]+single = liftM return++flat :: Monad m => m [[a]] -> m [a]+flat = liftM concat++enclosedBy :: Monad m => m [a] -> m a -> m [a]+enclosedBy p q = q <:> p <++> single q++-- * parsec shortcuts++-- | parse an optional list+optionL :: GenParser tok st [a] -> GenParser tok st [a]+optionL = option []++-- | shortcut for @try . string@+tryString :: String -> CharParser st String+tryString = try . string++-- | nested comments, open and closing strings must have at least two chars+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"++-- * haskell tokens++-- | the haskell nested comments+nestComment :: CharParser st String+nestComment = nestedComment "{-" "-}"++-- | line comment without final newline+lineComment :: CharParser st String+lineComment =+ try ((char '-' <:> many1 (char '-'))+ << notFollowedBy (oneOf "!#$%&*+./<=>?@\\^|~"))+ <++> many (noneOf "\n")++-- | text in double quotes+stringLit :: CharParser st String+stringLit = enclosedBy (flat $ many $ single (noneOf "\\\"")+ <|> char '\\' <:> single anyChar) $ char '\"'++-- | text in single quotes+charLit :: CharParser st String+charLit = tryString "'''" <|>+ enclosedBy (flat $ many $ single (noneOf "\\\'")+ <|> char '\\' <:> single anyChar)+ (char '\'')++-- | a precise number scanner+number :: Parser String+number =+ try (char '0' <:> single (oneOf "oO")) <++> many octDigit+ <|>+ try (char '0' <:> single (oneOf "xX")) <++> many hexDigit+ <|> many1 digit+ <++> optionL (try (char '.' <:> single digit) <++> many digit)+ <++> optionL (try (oneOf "eE" <:> optionL (single $ oneOf "+-")+ <++> single digit) <++> many digit)++-- | any character within identifiers+hChar :: Parser Char+hChar = alphaNum <|> oneOf "_'"++-- | the underscore parser+uL :: Parser Char+uL = char '_'++-- | lower case identifiers (aka variables)+lId :: Parser String+lId = (uL <|> lower) <:> many hChar++-- | upper case identifiers (aka constructors)+uId :: Parser String+uId = upper <:> many hChar++-- | any character within operators+opSym :: Parser Char+opSym = oneOf "!#$%&*+-./:<=>?@\\^|~"++-- | any operator (mainly infixes)+operator :: Parser String+operator = many1 opSym++-- | possible qualified entities: lower or upper case words or symbols+data QualElem = Var | Cons | Sym deriving Eq++-- | a name qualified or not with its representation+data QualName = Name Bool QualElem String++-- | the show instance renders the original string+instance Show QualName where+ show (Name _ _ s) = s++-- | any qualified or unqualified name or operator+qId :: Parser QualName+qId = fmap (Name False Var) lId+ <|> fmap (Name False Sym) operator+ <|> do+ n <- uId+ option (Name False Cons n) $ do+ d <- try (char '.' << lookAhead (uL <|> letter <|> opSym))+ Name _ k r <- qId+ return $ Name True k $ n ++ d : r++-- | parse any 'qId' within back ticks. This is more liberal than haskell!+infixOp :: Parser String+infixOp = enclosedBy (fmap show qId) $ char '`'++-- | the separators are comma, semicolon and various kinds of parens+seps :: String+seps = "[({,;})]\n"++-- | beside names and separators we have a couple of more token kinds+data TokenKind = LineComment | BlockComment | Literal | Infix++-- | the data type for tokens+data Token+ = QualName QualName+ | Sep Char+ | Token TokenKind String+ | Start -- ^ the void token at the very beginning++-- | the show instance renders the original string without kind information+instance Show Token where+ show t = case t of+ QualName q -> show q+ Sep c -> [c]+ Token _ s -> s+ Start -> ""++-- | all white spaces except newline+isWhite :: Char -> Bool+isWhite c = isSpace c && c /= '\n'++-- | parsing as many 'isWhite' characters as possible (or none)+white :: Parser String+white = many $ satisfy isWhite++-- | parse any non-white token+tok :: Parser Token+tok = fmap (Token BlockComment) nestComment+ <|> fmap (Token LineComment) lineComment+ <|> fmap QualName qId+ <|> fmap Sep (oneOf seps)+ <|> fmap (Token Literal) (charLit <|> stringLit <|> number)+ <|> fmap (Token Infix) infixOp++-- | tokens enriched by positions and following white space+data PosTok = PosTok SourcePos Token String++instance Show PosTok where+ show (PosTok _ t s) = shows t s++-- | attach positions and subsequent 'white' spaces to tokens+posTok :: Parser PosTok+posTok = do+ p <- getPosition+ t <- tok+ w <- white+ return $ PosTok p t w++-- | the start position (without file name)+startPos :: SourcePos+startPos = initialPos ""++-- | the initial 'white' stuff+startTok :: Parser PosTok+startTok = fmap (PosTok startPos Start) white++-- | the final scanner+scan :: Parser [PosTok]+scan = startTok <:> many posTok << eof++-- * splitting lines++{- | 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++-- | split lines at newline tokens+splitLines :: [PosTok] -> [[PosTok]]+splitLines = splitBy isIndent++-- | 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+data Diag = Diag SourcePos String++instance Show Diag where+ show (Diag p s) = show p ++ ' ' : s++-- * checking tokens++-- | only show the token without spaces+showTok :: PosTok -> String+showTok (PosTok _ t _) = show t++isInfixOp :: PosTok -> Bool+isInfixOp (PosTok _ t _) = case t of+ QualName (Name _ Sym s) -> notElem s $ map (: []) "!#@\\~"+ Token Infix _ -> True+ _ -> False++isComment :: PosTok -> Bool+isComment (PosTok _ t _) = case t of+ Token k _ -> case k of+ LineComment -> True+ BlockComment -> True+ _ -> False+ _ -> False++noLineComment :: PosTok -> Bool+noLineComment (PosTok _ t _) = case t of+ Token LineComment _ -> False+ _ -> True++isSepIn :: String -> PosTok -> Bool+isSepIn cs (PosTok _ t _) = case t of+ Sep c -> elem c cs+ _ -> False++isIndent :: PosTok -> Bool+isIndent = isSepIn "\n"++isOpPar :: PosTok -> Bool+isOpPar = isSepIn "[({"++isClPar :: PosTok -> Bool+isClPar = isSepIn "})]"++isOpParOrInfix :: PosTok -> Bool+isOpParOrInfix t = isOpPar t || isInfixOp t++isClParOrInfix :: PosTok -> Bool+isClParOrInfix t = isClPar t || isInfixOp t++isNonPar :: PosTok -> Bool+isNonPar = isSepIn ",;"++isFstInfixMinusArg :: PosTok -> Bool+isFstInfixMinusArg t@(PosTok _ u _) = case u of+ QualName (Name _ k _) -> k /= Sym+ Sep _ -> isClPar t+ Token k _ -> case k of+ Literal -> True+ Infix -> True+ _ -> False+ Start -> False++noSpaceNeededBefore :: PosTok -> Bool+noSpaceNeededBefore t =+ isSepIn ",;})]" t || showTok t == "@"++noSpaceNeededAfter :: PosTok -> Bool+noSpaceNeededAfter t@(PosTok _ u _) =+ isOpPar t || elem (show u) (map (: []) "!#-@~")++-- * 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 $ show t) w++-- | remove trailing spaces+rmSp :: PosTok -> PosTok+rmSp (PosTok p t _) = PosTok p t ""++-- | append exactly one blank+blank :: PosTok -> PosTok+blank (PosTok p t _) = PosTok p t " "++multipleBlanks :: PosTok -> [Diag]+multipleBlanks (PosTok p t w) = let n = length w in+ [ Diag (updatePosString p $ show t) $ "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++-- | check if prefix extended by one char from next string is still a prefix+hasLongerPrefix :: String -> String -> String -> Bool+hasLongerPrefix p n s = let ps = map (\ c -> p ++ [c]) n in+ any (`isPrefixOf` s) ps++-- | insert a single blank after prefix+adjustPrefix :: String -> String -> String -> String+adjustPrefix p n s =+ if hasLongerPrefix p n s then s else case stripPrefix p s of+ Nothing -> s+ Just r -> p ++ case dropWhile isWhite r of+ rt@('\n' : _) -> case s of+ '}' : _ -> r+ _ -> rt+ rt -> ' ' : rt++-- | adjust comment at both ends. Input is prefix, suffix and extension chars.+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++-- | adjust a block comment+adjustComment :: String -> String+adjustComment = adjustBothEnds "{-" "-}" "!#"+ . adjustBothEnds "{-!" "!-}" ""+ . adjustBothEnds "{-#" "#-}" ""++-- * 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+ n = adjustComment s+ s5 = take 5 s+ nr = take 5 $ reverse n+ sr = take 5 $ reverse s+ in (PosTok p (Token BlockComment n) w,+ [ Diag p $ "non-conventional comment start: " ++ s5 | s5 /= take 5 n ]+ ++ [ Diag (updatePosString p s) $ "non-conventional comment end: "+ ++ reverse sr | sr /= nr ])+ _ | show u == ";" -> (t, [Diag p "use layout instead of ;"])+ _ -> (t, [])++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 t1 -> let (ft, rt) = span (== ' ') w1 in+ (untab t1, cs +++ [ Diag (updatePosString p1 ft) "use only blanks for indentation"+ | not (null rt) ]) <+> anaLine r1+ _ -> let+ s1 = show u1+ s2 = show u2+ n1 = length s1+ n2 = length s2+ lt = n1 <= n2+ both = s1 ++ s2+ after = case () of+ _ | isNonPar t1 -> True+ | isOpPar t2 -> False+ | s1 == "\\" -> True+ | isInfixOp t1 -> if isInfixOp t2 then lt else True+ | isInfixOp t2 || s2 == ".." -> False+ _ -> lt+ parsOfBoth = filter (`elem` "[({})]") both+ pos = case both of+ _ : _ : _ -> "between"+ _ | isOpPar t1 -> "after"+ | isClPar t2 -> "before"+ _ -> "here"+ omitSpace = isOpParOrInfix t1 && isClParOrInfix t2+ && not (isInfixOp t1 && isInfixOp t2)+ && (s1 /= ".." || s2 /= "]")+ addSpace = not (noSpaceNeededAfter t1)+ && not (noSpaceNeededBefore t2)+ (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 "but may be template haskell splice $("+ | both == "$(" ])+ else (t1, [])+ else if omitSpace+ then (rmSp t1,+ [Diag p2 $ " no space needed " ++ pos ++ " " ++ parsOfBoth])+ else if isComment t2+ then (untab t1, [])+ else (blank t1, multipleBlanks t1)+ pt0 = (newT1, cs ++ ds)+ in case r2 of+ [] -> pt0 <+> anaLine r1+ t3@(PosTok _ u3 _) : _ -> let+ s3 = show u3+ ms = [Diag p2 "put spaces around infix -" | null w1 || null w2 ]+ ++ multipleBlanks t1 ++ multipleBlanks t2+ in if s2 == "-" && not (noSpaceNeededBefore t3)+ && isFstInfixMinusArg t1+ then (blank t1, cs ++ ms) <+> anaLine (blank t2 : r2)+ else (if elem s2 ["do", "of"] && s3 /= "{" && noLineComment t3+ 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] -> isIndent t+ _ -> False++removeFinalBlankLines :: [[PosTok]] -> [[PosTok]]+removeFinalBlankLines ll = reverse $ [PosTok startPos (Sep '\n') ""]+ : dropWhile isBlankLine (reverse ll)++-- * main functions++-- | create adjusted source file+processScan :: [[PosTok]] -> String+processScan = concatMap (concatMap show . fst . anaLine)+ . removeBlankLines 1 isBlankLine . removeFinalBlankLines++-- | list all diagnostics+showScan :: [[PosTok]] -> String+showScan = intercalate "\n" . concatMap (map show . snd . anaLine)
src/scan.hs view
@@ -54,7 +54,7 @@ checkBlankLines :: FilePath -> Int -> [(Int, String)] -> [String] checkBlankLines f c l = case l of- [] -> if c > 0 then ["trailing blank lines"] else []+ [] -> ["trailing blank lines" | c > 0] (n, s) : r -> if null $ filter (not . isSpace) s then if c >= 2 then