scan 0.1.0.5 → 0.1.0.6
raw patch · 3 files changed
+196/−77 lines, 3 files
Files
- scan.cabal +1/−1
- src/Language/Haskell/Scanner.hs +109/−49
- src/scan.hs +86/−27
scan.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.4 build-type: Simple name: scan-version: 0.1.0.5+version: 0.1.0.6 license: BSD3 license-file: doc/LICENSE category: Development
src/Language/Haskell/Scanner.hs view
@@ -18,7 +18,7 @@ , Opts (..) , defaultOpts , anaPosToks- , PosTok(..)+ , PosTok (..) , Token , showPosTok , Diag (..)@@ -60,6 +60,15 @@ enclosedBy :: Monad m => m [a] -> m a -> m [a] enclosedBy p q = q <:> p <++> single q +-- | a literal enclosed in quotes and a backslash as escape character+quotedLit :: Char -> CharParser st String+quotedLit q = enclosedBy (flat $ many $ single (noneOf $ '\\' : [q])+ <|> char '\\' <:> single anyChar) $ char q++-- | text in double quotes+stringLit :: CharParser st String+stringLit = quotedLit '"'+ -- * parsec shortcuts -- | parse an optional list@@ -96,17 +105,9 @@ << 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 '\'')+charLit = tryString "'''" <|> quotedLit '\'' -- | a precise number scanner number :: Parser String@@ -330,16 +331,6 @@ rmSp :: PosTok -> PosTok rmSp (PosTok p t _) = PosTok p t "" --- | ensure proper amount of space-blank :: Opts -> Token -> PosTok -> PosTok-blank opts u (PosTok p t w) = PosTok p t- $ let n = maxBlanks opts in- if null w || noMultBlanksAfter opts t || noMultBlanksBefore opts u- then " " else- if allowMultBlanksAfter opts t || allowMultBlanksBefore opts u- then if n > 1 then take n w else w- else take n w- topKeys :: [String] topKeys = ["import", "data", "newtype", "type", "class", "instance"] -- "module" may occur in export lists!@@ -347,20 +338,25 @@ layoutKeys :: [String] layoutKeys = ["do", "of", "where"] -multipleBlanks :: Opts -> Token -> PosTok -> [Diag]-multipleBlanks opts u (PosTok p t w) =+-- | ensure proper amount of space and diagnose too many blanks+multipleBlanks :: Opts -> Token -> PosTok -> (PosTok, [Diag])+multipleBlanks opts u pTok@(PosTok p t w) = let s = showToken t q = updatePosString p s aft = noMultBlanksAfter opts t m = maxBlanks opts n = length w- in [ Diag q $ "up to column " ++ show (sourceColumn q + n)+ diag = Diag q $ "up to column " ++ show (sourceColumn q + n) ++ " multiple (" ++ show n ++ ") blanks" ++ if aft then " after " ++ show s else ""- | n > m && m > 1 || n > 1 && (aft || noMultBlanksBefore opts u)- || n > 1 && m == 1- && not (allowMultBlanksAfter opts t || allowMultBlanksBefore opts u)- ]+ bTok = PosTok p t " "+ in case w of+ "" -> (bTok, []) -- insert a missing blank (without diag)+ _ | allowMultBlanksBefore opts u+ -> (pTok, []) -- no change+ _ | noMultBlanksAfter opts t+ -> (bTok, [diag | n > 1])+ _ -> (PosTok p t $ take m w, [diag | n > m]) -- | tidy up line comments adjustLineComment :: String -> String@@ -407,6 +403,7 @@ sr = take 5 $ reverse s in (PosTok p (Token BlockComment n) w, [ Diag p $ "non-conventional comment start: " ++ s5 | s5 /= take 5 n ]+ ++ [ 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@@ -419,35 +416,69 @@ ++ "one blank after --" ++ if null sr then "" else " in --" ++ sr | s4 /= take 4 n ]- ++ [ Diag q "missing comment after --" | n == "--" ])+ ++ [ Diag q "missing comment after --" | n == "--" ]+ ++ [ Diag q "line comment contains block comment start"+ | isInfixOf "{-" n ]+ ++ [ Diag q "line comment contains block comment end"+ | isInfixOf "-}" n ]) _ -> (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"]++-- | a comment that is no pragma or directive+isNormalComment :: PosTok -> Bool+isNormalComment p@(PosTok _ u _) =+ isComment u && isNormalCommentString (showPosTok $ fst $ anaPosTok p)++-- | check if no other normal comment follows+noOtherComment :: [PosTok] -> Bool+noOtherComment ps = case ps of+ [] -> True+ p : _ -> not $ isNormalComment p+ -- | the data type for options passed to the analysis data Opts = Opts { tempHask :: Bool+ , windowsOutput :: Bool+ , lineLength :: Int+ , maxBlankLines :: Int , maxBlanks :: Int , allowMultBlanksBefore :: Token -> Bool- , allowMultBlanksAfter :: Token -> Bool- , noMultBlanksBefore :: Token -> Bool , noMultBlanksAfter :: Token -> Bool+ , makeLineComments :: Bool+ , joinComments :: Bool+ , ignoreComments :: Bool+ , commentGap :: Int+ , checkSpacing :: Bool } -- | the default options to use defaultOpts :: Opts defaultOpts = Opts { tempHask = False+ , windowsOutput = False+ , lineLength = 80+ , maxBlankLines = 2 , maxBlanks = 1 , allowMultBlanksBefore = isComment- , allowMultBlanksAfter = const False- , noMultBlanksBefore = const False , noMultBlanksAfter = isKeyw $ "let" : layoutKeys+ , makeLineComments = True+ , joinComments = True+ , ignoreComments = False+ , commentGap = 0+ , checkSpacing = True } -- | analyse consecutive tokens anaPosToks :: Opts -> [PosTok] -> ([PosTok], [Diag])-anaPosToks opts l = case l of+anaPosToks opts l = let ignoreC = ignoreComments opts in case l of [] -> ([], [])- t0 : r1 -> let (t1@(PosTok p1 u1 w1), cs) = anaPosTok t0 in case r1 of+ t0 : r1 ->+ let (tC@(PosTok p1 u1 w1), cC) = anaPosTok t0+ (t1, cs) = if ignoreC then (t0, []) else (tC, cC)+ in case r1 of [] -> ([t1], cs) t2@(PosTok p2 u2 w2) : r2 -> let (ar1, rds) = anaPosToks opts r1@@ -462,11 +493,9 @@ lt = length s1 <= length s2 both = s1 ++ s2 nw1 = null w1- bt1 = blank opts u2 t1+ (bt1, m1) = multipleBlanks opts u2 t1 al = t1 : ar1 bl = bt1 : ar1- rl = rmSp t1 : ar1- m1 = multipleBlanks opts u2 t1 aS = "after " bS = "before " aft = case () of@@ -482,32 +511,63 @@ _ | o1 -> aS | c2 -> bS _ -> "here "- omitSpace = o1 && (isInfixOp u2 || c2)+ checkS = checkSpacing opts+ joinC = joinComments opts+ omitSpace = checkS && o1 && (isInfixOp u2 || c2) || isInfixOp u1 && c2 && not (isSymb [".."] u1 && isSepIn "]" u2)- addSpace = ni1 && nw1+ addSpace = checkS && ni1 && nw1 && (not (o1 || isSymb (map (: []) "!#-@~") u1) || isComment u2) && spaceNeededBefore u2 && if tempHask opts then not $ isSymb ["$"] u1 else True+ s1C = take (length s1 - 3) s1 in case r2 of- _ | isComment u1 && isIndent u2- -> (al, cs ++ [ Diag p1 "could be a line comment"- | isPrefixOf "{- " s1 && not (any (== '\n') s1) ] ++ rds)- PosTok _ u3 _ : _- | isFstInfixMinusArg u1 && isSymb ["-"] u2 && spaceNeededBefore u3- -> (bt1 : blank opts u3 t2 : tail ar1, cs ++ m1+ _ | makeLineComments opts && isComment u1 && isIndent u2+ && noOtherComment r2 && isPrefixOf "{- " s1C+ && not (any (== '\n') s1C)+ -> ( PosTok p1 (Token LineComment $ "-- " ++ drop 3 s1C) "" : ar1+ , cs ++ Diag p1 "could be a line comment" : rds)+ | joinC && isNormalComment tC && isNormalComment t2+ -> (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)+ hh3 = head h3+ isHaddockStart = not (null h3) && any (hh3 ==) "$*^|"+ s3 = if isHaddockStart+ then dropWhile isSpace+ $ if hh3 == '*' then dropWhile (== '*') h3 else tail h3+ else h3+ nt3 = PosTok p1 (Token BlockComment+ $ (if noLineComment u1 then s1C+ else "{- " ++ drop 3 s1)+ ++ w1 ++ s2 ++ w2 ++ replicate (commentGap opts) ' '+ ++ if noLineComment nu3 then s3+ else s3 ++ " -}") w3+ (ar3, rds3) = anaPosToks opts $ nt3 : r3+ in (ar3+ , cs ++ Diag p3 "join (or separate) consecutive comments"+ : [ Diag (updatePosString p3 f3)+ $ "unexpected haddock marker " ++ [hh3]+ | isHaddockStart ]+ ++ (if ignoreC then [] else cs3) ++ rds3)+ | checkS && isFstInfixMinusArg u1 && isSymb ["-"] u2+ && spaceNeededBefore u3+ -> let (bt2, m2) = multipleBlanks opts u3 t2 in+ (bt1 : bt2 : tail ar1, cs ++ m1 ++ [ Diag p2 "put blanks around infix -" | nw1 || null w2 ]- ++ multipleBlanks opts u3 t2 ++ rds)+ ++ m2 ++ rds) | ni1 && isKeyw layoutKeys u2 && not (isSepIn "{" u3) && noLineComment u3 && not (isIndent u3)- -> (bl, cs ++ m1 ++ Diag p2 ("break line after " ++ show s2) : rds)+ -> (al, cs ++ m1 ++ Diag p2 ("break line after " ++ show s2) : rds) _ | addSpace -> (bl, cs ++ Diag p2 ("put blank " ++ if aft then aS ++ s1 else bS ++ s2) : rds) _ | not nw1 && omitSpace- -> (rl, cs+ -> (rmSp t1 : ar1, cs ++ Diag p2 ("no space needed " ++ pos ++ parsOfBoth) : rds) _ | not nw1 && ii1 && isKeyw topKeys u2- -> (rl, cs ++ Diag p2 ("start in column 1 with keyword " ++ s2) : rds)+ -> (al, cs ++ Diag p2 ("start in column 1 with keyword " ++ s2) : rds) _ | nw1 || ii1 -> (al, cs ++ rds) _ -> (bl, cs ++ m1 ++ rds)
src/scan.hs view
@@ -35,16 +35,25 @@ -- | the hard-coded version string. version :: String-version = "scan-0.1.0.5 http://projects.haskell.org/style-scanner/"+version = "scan-0.1.0.6 http://projects.haskell.org/style-scanner/" data Flag = Help | Version | TempHask+ | WindowsOutput | LineLen Int | MaxBlanks Int | BackupExt String+ | OutputExt String | OutputFile FilePath+ | OutputDir FilePath+ | MaxBlankLines Int+ | CheckSpacing Bool+ | CheckComments Bool+ | MakeLineComments Bool+ | JoinComments Bool+ | CommentGap Int deriving (Show, Eq) -- | describe all available options@@ -54,37 +63,75 @@ "show usage message and exit" , Option "v" ["version"] (NoArg Version) "show version and exit"+ , Option "w" ["windows"] (NoArg WindowsOutput)+ "create windows (CRLF) file" , Option "t" ["template-haskell"] (NoArg TempHask) "no hints for $ in template haskell"- , Option "l" ["line-length"] (ReqArg (LineLen . read) "<n>")+ , Option "l" ["line-length"] (ReqArg (LineLen . readN) "<n>") "report lines longer than <n> (default -l80)"- , Option "m" ["multiple-blanks"] (ReqArg (MaxBlanks . read) "<n>")+ , Option "m" ["multiple-blanks"] (ReqArg (MaxBlanks . readN) "<n>") "report more than <n> blanks (default -m1)"+ , Option "s" ["check-spacing"] (ReqArg (CheckSpacing . readB) "<b>")+ "check spacing around symbols (default True)"+ , Option "c" ["check-comments"] (ReqArg (CheckComments . readB) "<b>")+ "check comment delimiters (default True)"+ , Option "C" ["change-comments"] (ReqArg (MakeLineComments . readB) "<b>")+ "change to some line comments (default True)"+ , Option "j" ["join-comments"] (ReqArg (JoinComments . readB) "<b>")+ "join consecutive comments (default True)"+ , Option "g" ["comment-gap"] (ReqArg (CommentGap . readN) "<n>")+ "spaces between joined comments (default -g0)"+ , Option "b" ["blank-lines"] (ReqArg (MaxBlankLines . readN) "<n>")+ "remove more than <n> blank lines (default -r2)" , Option "i" ["inplace-modify"] (OptArg (BackupExt . fromMaybe "") "<ext>") "modify file in place (backup if <ext> given)"+ , Option "e" ["extension"] (ReqArg OutputExt "<ext>")+ "create output file with given extension <ext>" , Option "o" ["output-file"] (ReqArg OutputFile "<file>") "output modified input to <file>"- ]+ , Option "O" ["output-directory"] (ReqArg OutputDir "<dir>")+ "output modified file to <dir>"+ ] output :: FilePath -> [Flag] -> Maybe (FilePath, Maybe FilePath)-output p = foldl (\ m f -> case f of- OutputFile str -> Just (str, maybe Nothing snd m)- BackupExt ext ->- Just (p, if null ext then Nothing else Just $ p ++ "." ++ ext)+output p = foldl (\ m f -> let o = maybe Nothing snd m in case f of+ OutputFile s -> Just (s, o)+ BackupExt e ->+ Just (p, if null e then o else Just $ p ++ '.' : e)+ OutputExt e ->+ Just (p ++ '.' : e, o)+ OutputDir d ->+ Just (d ++ '/' : p, o) _ -> m) Nothing -lineLength :: [Flag] -> Int-lineLength = foldl (\ m f -> case f of- LineLen n -> n- _ -> m) 80+readN :: String -> Int+readN s = if not (null s) && all isDigit s && length s < 4 then read s+ else error $ "expected small number argument but got: " ++ s +readB :: String -> Bool+readB s = case map toLower s of+ t@(_ : _)+ | elem t $ inits "true" -> True+ | elem t $ inits "false" -> False+ _ -> error $+ "expected case-insensitive partial boolean argument but got: " ++ s+ anaOpts :: [Flag] -> Opts anaOpts = foldl (\ m f -> case f of TempHask -> m { tempHask = True }+ WindowsOutput -> m { windowsOutput = True }+ LineLen n -> m { lineLength = n }+ MaxBlankLines n -> m { maxBlankLines = n } MaxBlanks n -> if n <= 0 then m { maxBlanks = maxBound , noMultBlanksAfter = const False } else m { maxBlanks = n }++ CheckSpacing b -> m { checkSpacing = b }+ CheckComments b -> m { ignoreComments = not b }+ MakeLineComments b -> m { makeLineComments = b }+ JoinComments b -> m { joinComments = b }+ CommentGap n -> m { commentGap = n } _ -> m) defaultOpts {- arguments starting with a minus sign are treated as options. files that@@ -107,9 +154,11 @@ unless (null errs) exitFailure _ | elem Version flags -> putStrLn version+ _ | length (show flags) < 0 -- force evaluation of flags+ -> exitFailure file : r -> let out = output file flags- proc = process out (lineLength flags) (anaOpts flags)+ proc = process out (anaOpts flags) in case out of Just _ | null r -> proc file Nothing -> mapM_ proc files@@ -124,13 +173,17 @@ {- | process a file. A first true arguments only shows diagnostics. A first false argument writes back a modified file, but only if there are modifications. -}-process :: Maybe (FilePath, Maybe FilePath) -> Int -> Opts -> FilePath -> IO ()-process out ll opts f = do+process :: Maybe (FilePath, Maybe FilePath) -> Opts -> FilePath -> IO ()+process out opts f = do str <- readFile f let ls = lines str- wcsr = map (checkLine ll f) (zip [1 ..] ls)+ wcsr = map (checkLine (lineLength opts) f) (zip [1 ..] ls) wcs = map fst wcsr- wfile = [ Diag (diagLinePos f 2) "windows (CRLF) file" ]+ isWin = windowsOutput opts+ m = maxBlankLines opts+ crPos = diagLinePos f 2+ wfile = if isWin then [] else+ [ Diag crPos "windows (CRLF) file" ] noNL = not $ isSuffixOf "\n" str cs = case group $ map fst wcs of [True : _, [False]] | noNL -> wfile -- with missing newline@@ -138,8 +191,10 @@ [ Diag (diagLinePos f (length x + 1)) "inconsistent unix (LF) or windows (CRLF) file" ] [True : _] -> wfile+ [False : _] -> [ Diag crPos "unix (LF) file" | isWin ] _ -> []- ++ concatMap snd wcs ++ checkBlankLines f 0 0 ls+ ++ concatMap snd wcs+ ++ if m > 0 then checkBlankLines f m 0 0 ls else [] newStr = unlines $ map snd wcsr fs = [ Diag (diagLinePos f $ length ls) "missing final newline" | noNL ] prDiags = mapM_ (putStrLn . showDiag)@@ -147,7 +202,10 @@ Right ts -> let (nts, ds) = anaPosToks opts ts in case out of Nothing -> prDiags $ cs ++ ds ++ fs Just (ofile, mbak) ->- let rstr = unlines . removeBlankLines 0 null . lines+ let rstr =+ (if isWin then concatMap (++ "\r\n") else unlines)+ . (if m > 0 then removeBlankLines m 0 null else id)+ . lines $ concatMap showPosTok nts in if rstr == str then putStrLn $ "no change for file: " ++ f else do case mbak of@@ -169,26 +227,27 @@ "expecting" "unexpected" "end of input" (errorMessages err) --- | check for more than two consecutive lines+-- | check for more than n consecutive lines checkBlankLines :: FilePath+ -> Int -- ^ maximal allowed number of blank lines -> 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+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 (c + 1) n1 r+ if null $ filter (not . isSpace) s then checkBlankLines f m (c + 1) n1 r else [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines"- | c > 2 ] ++ checkBlankLines f 0 n1 r+ | c > m ] ++ checkBlankLines f m 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+removeBlankLines :: Int -> Int -> ([a] -> Bool) -> [[a]] -> [[a]]+removeBlankLines m 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+ then removeBlankLines m (c + 1) p r+ else replicate (min m c) [] ++ x : removeBlankLines m 0 p r -- | create a position from a file and a line number diagLinePos :: FilePath -> Int -> SourcePos