diff --git a/scan.cabal b/scan.cabal --- a/scan.cabal +++ b/scan.cabal @@ -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 diff --git a/src/Language/Haskell/Scanner.hs b/src/Language/Haskell/Scanner.hs --- a/src/Language/Haskell/Scanner.hs +++ b/src/Language/Haskell/Scanner.hs @@ -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) diff --git a/src/scan.hs b/src/scan.hs --- a/src/scan.hs +++ b/src/scan.hs @@ -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 [-] [--] +" +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) "") + "report lines longer than (default -l80)" + , Option "m" ["multiple-blanks"] (ReqArg (MaxBlanks . read) "") + "report more than blanks (default -m1)" + , Option "i" ["inplace-modify"] (OptArg (BackupExt . fromMaybe "") "") + "modify file in place (backup if given)" + , Option "o" ["output-file"] (ReqArg OutputFile "") + "output modified input to " + ] + +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] [--] +") 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)"