scan 0.1.0.3 → 0.1.0.4
raw patch · 3 files changed
+211/−107 lines, 3 files
Files
- scan.cabal +1/−1
- src/Language/Haskell/Scanner.hs +112/−79
- src/scan.hs +98/−27
scan.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.4 build-type: Simple name: scan-version: 0.1.0.3+version: 0.1.0.4 license: BSD3 license-file: doc/LICENSE category: Development
src/Language/Haskell/Scanner.hs view
@@ -15,9 +15,11 @@ module Language.Haskell.Scanner ( scan- , showScan- , processScan+ , Opts (..)+ , defaultOpts+ , anaPosToks , PosTok+ , showPosTok , Diag (..) , showDiag , showSourcePos@@ -253,7 +255,7 @@ showSourcePos :: SourcePos -> String showSourcePos p = sourceName p ++ ":" ++ shows (sourceLine p) ":"- ++ shows (sourceColumn p) ":"+ ++ shows (sourceColumn p) ":" showDiag :: Diag -> String showDiag (Diag p s) = showSourcePos p ++ ' ' : s@@ -295,15 +297,6 @@ isClPar :: Token -> Bool isClPar = isSepIn "})]" -isOpParOrInfix :: Token -> Bool-isOpParOrInfix t = isOpPar t || isInfixOp t--isClParOrInfix :: Token -> Bool-isClParOrInfix t = isClPar t || isInfixOp t--isNonPar :: Token -> Bool-isNonPar = isSepIn ",;"- isFstInfixMinusArg :: Token -> Bool isFstInfixMinusArg t = case t of QualName (Name _ k _) -> case k of@@ -311,7 +304,6 @@ _ -> True Token k _ -> case k of Literal -> True- Infix -> True Sep -> isClPar t _ -> False @@ -320,13 +312,14 @@ QualName (Name False Sym r) -> elem r s _ -> False -noSpaceNeededBefore :: Token -> Bool-noSpaceNeededBefore t =- isSepIn ",;})]" t || isIndent t || isSymb ["-", "@"] t+isKeyw :: [String] -> Token -> Bool+isKeyw s t = case t of+ QualName (Name False Var r) -> elem r s+ _ -> False -noSpaceNeededAfter :: Token -> Bool-noSpaceNeededAfter t =- isOpPar t || isIndent t || isSymb (map (: []) "!#-@~") t+spaceNeededBefore :: Token -> Bool+spaceNeededBefore t =+ not $ isIndent t || isSymb ["@"] t || isSepIn ",;})]" t -- * adjusting tokens @@ -334,16 +327,37 @@ rmSp :: PosTok -> PosTok rmSp (PosTok p t _) = PosTok p t "" --- | append exactly one blank-blank :: PosTok -> PosTok-blank (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 -multipleBlanks :: PosTok -> [Diag]-multipleBlanks (PosTok p t w) =- let q = updatePosString p $ showToken t+topKeys :: [String]+topKeys = ["import", "data", "newtype", "type", "class", "instance"]+-- "module" may occur in export lists!++layoutKeys :: [String]+layoutKeys = ["do", "of", "where"]++multipleBlanks :: Opts -> Token -> PosTok -> [Diag]+multipleBlanks opts u (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)- ++ " multiple (" ++ show n ++ ") blanks" | n > 1 ]+ ++ " 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)+ ] -- | tidy up line comments adjustLineComment :: String -> String@@ -405,26 +419,55 @@ ++ [ Diag q "missing comment after --" | n == "--" ]) _ -> (t, [ Diag p "use layout instead of ;" | isSepIn ";" u ]) -anaLine :: [PosTok] -> ([PosTok], [Diag])-anaLine l = case l of+-- | the data type for options passed to the analysis+data Opts = Opts+ { tempHask :: Bool+ , maxBlanks :: Int+ , allowMultBlanksBefore :: Token -> Bool+ , allowMultBlanksAfter :: Token -> Bool+ , noMultBlanksBefore :: Token -> Bool+ , noMultBlanksAfter :: Token -> Bool+ }++-- | the default options to use+defaultOpts :: Opts+defaultOpts = Opts+ { tempHask = False+ , maxBlanks = 1+ , allowMultBlanksBefore = isComment+ , allowMultBlanksAfter = const False+ , noMultBlanksBefore = const False+ , noMultBlanksAfter = isKeyw $ "let" : layoutKeys+ }++-- | analyse consecutive tokens+anaPosToks :: Opts -> [PosTok] -> ([PosTok], [Diag])+anaPosToks opts l = case l of [] -> ([], []) t0 : r1 -> let (t1@(PosTok p1 u1 w1), cs) = anaPosTok t0 in case r1 of [] -> ([t1], cs) t2@(PosTok p2 u2 w2) : r2 -> let- (ar1, rds) = anaLine r1+ (ar1, rds) = anaPosToks opts r1 s1 = showToken u1 s2 = showToken u2 i1 = isInfixOp u1 i2 = isInfixOp u2- n1 = length s1- n2 = length s2- lt = n1 <= n2+ o1 = isOpPar u1+ c2 = isClPar u2+ ii1 = isIndent u1+ ni1 = not ii1+ lt = length s1 <= length s2 both = s1 ++ s2 nw1 = null w1- bt1 = blank t1- m1 = multipleBlanks t1- after = case () of- _ | isNonPar u1 -> True+ bt1 = blank 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+ _ | isSepIn ",;" u1 -> True | isOpPar u2 -> False | isSymb ["\\"] u1 -> True | i1 -> if i2 then lt else True@@ -432,46 +475,36 @@ _ -> lt parsOfBoth = filter (`elem` "[({})]") both pos = case parsOfBoth of- _ : _ : _ -> "between"- _ | isOpPar u1 -> "after"- | isClPar u2 -> "before"- _ -> "here"- omitSpace = isOpParOrInfix u1 && isClParOrInfix u2- && not (i1 && i2)- && (not (isSymb [".."] u1) || not (isSepIn "]" u2))- addSpace = not (noSpaceNeededAfter u1)- && not (noSpaceNeededBefore u2)- 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---- | create adjusted source file-processScan :: [PosTok] -> String-processScan = concatMap showPosTok . fst . anaLine---- | list all diagnostics-showScan :: [PosTok] -> [Diag]-showScan = snd . anaLine+ _ : _ : _ -> "between "+ _ | o1 -> aS+ | c2 -> bS+ _ -> "here "+ omitSpace = o1 && (isInfixOp u2 || c2)+ || isInfixOp u1 && c2 && not (isSymb [".."] u1 && isSepIn "]" u2)+ addSpace = ni1 && nw1+ && (not (o1 || isSymb (map (: []) "!#-@~") u1) || isComment u2)+ && spaceNeededBefore u2+ && if tempHask opts then not $ isSymb ["$"] u1 else True+ 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+ ++ [ Diag p2 "put blanks around infix -" | nw1 || null w2 ]+ ++ multipleBlanks opts u3 t2 ++ rds)+ | ni1 && isKeyw layoutKeys u2+ && not (isSepIn "{" u3) && noLineComment u3 && not (isIndent u3)+ -> (bl, 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+ ++ 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)+ _ | nw1 || ii1+ -> (al, cs ++ rds)+ _ -> (bl, cs ++ m1 ++ rds)
src/scan.hs view
@@ -13,11 +13,16 @@ module Main () where +import Control.Monad+ import Data.Char import Data.List+import Data.Maybe import System.Environment+import System.Console.GetOpt import System.Exit+ import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Pos import Text.ParserCombinators.Parsec.Error@@ -30,12 +35,58 @@ -- | the hard-coded version string. version :: String-version = "scan-0.1.0.3 http://projects.haskell.org/style-scanner/"+version = "scan-0.1.0.4 http://projects.haskell.org/style-scanner/" --- | the usage string-usage :: String-usage = "usage: scan [-] [--] <file>+"+data Flag =+ Help+ | Version+ | TempHask+ | LineLen Int+ | MaxBlanks Int+ | BackupExt String+ | OutputFile FilePath+ deriving (Show, Eq) +-- | describe all available options+options :: [OptDescr Flag]+options =+ [ Option "h" ["help"] (NoArg Help)+ "show usage message and exit"+ , Option "v" ["version"] (NoArg Version)+ "show version and exit"+ , Option "t" ["template-haskell"] (NoArg TempHask)+ "no hints for $ in template haskell"+ , Option "l" ["line-length"] (ReqArg (LineLen . read) "<n>")+ "report lines longer than <n> (default -l80)"+ , Option "m" ["multiple-blanks"] (ReqArg (MaxBlanks . read) "<n>")+ "report more than <n> blanks (default -m1)"+ , Option "i" ["inplace-modify"] (OptArg (BackupExt . fromMaybe "") "<ext>")+ "modify file in place (backup if <ext> given)"+ , Option "o" ["output-file"] (ReqArg OutputFile "<file>")+ "output modified input to <file>"+ ]++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)+ _ -> m) Nothing++lineLength :: [Flag] -> Int+lineLength = foldl (\ m f -> case f of+ LineLen n -> n+ _ -> m) 80++anaOpts :: [Flag] -> Opts+anaOpts = foldl (\ m f -> case f of+ TempHask -> m { tempHask = True }+ MaxBlanks n -> if n <= 0 then+ m { maxBlanks = maxBound+ , noMultBlanksAfter = const False }+ else m { maxBlanks = n }+ _ -> m) defaultOpts+ {- arguments starting with a minus sign are treated as options. files that start with a minus sign must follow an "--" option. -} @@ -43,27 +94,41 @@ main :: IO () main = do args <- getArgs+ prN <- getProgName let (optsOrFiles, files1) = span (/= "--") args- (opts, files2) = partition- (\ arg -> isPrefixOf "-" arg || all isDigit arg) optsOrFiles+ (flags, files2, errs) = getOpt Permute options optsOrFiles files = files2 ++ drop 1 files1- case opts of- [] -> case files of- [] -> mapM_ putStrLn ["missing file argument", usage]- _ -> mapM_ (process True) files- ["-"] -> case files of- [file] -> process False file- _ -> putStrLn "expected single file with \"-\" option"- _ -> mapM_ putStrLn [version, usage]+ help = elem Help flags+ case files of+ _ | help || not (null errs)+ -> do+ mapM_ putStr $ errs +++ [usageInfo ("usage: " ++ prN ++ " [options] [--] <file>+") options]+ unless (null errs) exitFailure+ _ | elem Version flags+ -> putStrLn version+ file : r -> let+ out = output file flags+ proc = process out (lineLength flags) (anaOpts flags)+ in case out of+ Just _ | null r -> proc file+ Nothing -> mapM_ proc files+ _ -> do+ putStrLn "input single file for modifications:"+ putStrLn $ concatMap ((' ' :) . show) files+ exitFailure+ [] -> do+ putStrLn "missing file argument"+ exitFailure {- | 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 :: Bool -> FilePath -> IO ()-process b f = do+process :: Maybe (FilePath, Maybe FilePath) -> Int -> Opts -> FilePath -> IO ()+process out ll opts f = do str <- readFile f let ls = lines str- wcsr = map (checkLine f) (zip [1 ..] ls)+ wcsr = map (checkLine ll f) (zip [1 ..] ls) wcs = map fst wcsr wfile = [ Diag (diagLinePos f 2) "windows (CRLF) file" ] noNL = not $ isSuffixOf "\n" str@@ -79,13 +144,19 @@ fs = [ Diag (diagLinePos f $ length ls) "missing final newline" | noNL ] prDiags = mapM_ (putStrLn . showDiag) 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- putStrLn $ "updated \"" ++ f ++ "\" (and created .bak)"+ 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+ $ concatMap showPosTok nts in+ if rstr == str then putStrLn $ "no change for file: " ++ f else do+ case mbak of+ Nothing -> return ()+ Just bak -> do+ writeFile bak str+ putStrLn $ "created backup file: " ++ bak+ writeFile ofile rstr+ putStrLn $ "wrote file: " ++ ofile Left err -> do prDiags cs putStrLn $ showParseError err@@ -124,8 +195,8 @@ diagLinePos = setSourceLine . initialPos -- | check length, chars and end of a line-checkLine :: FilePath -> (Int, String) -> ((Bool, [Diag]), String)-checkLine f (n, s) =+checkLine :: Int -> FilePath -> (Int, String) -> ((Bool, [Diag]), String)+checkLine ll f (n, s) = let r = reverse s (sps, rt) = span isSpace r (w, ws) = case sps of@@ -137,7 +208,7 @@ l = length v trailBSlash = takeWhile (== '\\') rt in ((w,- [ Diag p $ "too long line (" ++ show l ++ " chars)" | l > 80 ]+ [ Diag p $ "too long line (" ++ show l ++ " chars)" | l > ll ] ++ badChars p t ++ [ Diag (setSourceColumn p l) "back slash at line end (may disturb cpp)"