scan-0.1.0.2: src/scan.hs

{- |
Module      :  scan.hs
Description :  the standalone Haskell style scanner
Copyright   :  (c) Christian Maeder 2010
License     :  BSD

Maintainer  :  chr.maeder@web.de
Stability   :  experimental
Portability :  portable

the Haskell style scanner
-}

module Main () where

import Control.Monad

import Data.Char
import Data.List

import System.Environment
import System.Exit
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import Text.ParserCombinators.Parsec.Error

import Language.Haskell.Scanner

{- I do not import Paths_scan, because Data.Version is not portable due to the
imported Text.ParserCombinators.ReadP that uses local universal
quantification. -}

-- | the hard-coded version string.
version :: String
version = "scan-0.1.0.2 http://projects.haskell.org/style-scanner/"

-- | the usage string
usage :: String
usage = "usage: scan [-] [--] <file>+"

{- arguments starting with a minus sign are treated as options. files that
start with a minus sign must follow an "--" option. -}

-- | get arguments, separate options, and process files
main :: IO ()
main = do
  args <- getArgs
  let (optsOrFiles, files1) = span (/= "--") args
      (opts, files2) = partition (isPrefixOf "-") 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]

{- | 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
  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 ]
      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
      if rstr == str then putStrLn $ "no changes in \"" ++ f ++ "\"" else do
      writeFile (f ++ ".bak") str
      writeFile f rstr
      putStrLn $ "updated \"" ++ f ++ "\" (and created .bak)"
    Left err -> do
      prDiags cs
      putStrLn $ showParseError err
      exitFailure

-- | shows a parser error where the position is printed as for all diagnostics
showParseError :: ParseError -> String
showParseError err = showSourcePos (errorPos err)
  ++ showErrorMessages "or" "unknown parse error"
         "expecting" "unexpected" "end of input"
         (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]
  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

-- | 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 f (n, s) =
  let r = reverse s
      rt = dropWhile isSpace r
      l = length rt
      trailBSlash = takeWhile (== '\\') rt
      p = diagLinePos f n
  in [Diag p $ "too long line (" ++ show l ++ " chars)" | l > 80]
  ++ badChars p s
  ++ [Diag (updatePosString p $ init s)
       "back slash at line end (may disturb cpp)"
     | not (null trailBSlash)]

-- | create diagnostics for bad characters in a line
badChars :: SourcePos -> String -> [Diag]
badChars p s =
  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))
         (updatePosString p h) r