scan-0.1.0.3: 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 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.3 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
        (\ arg -> isPrefixOf "-" arg || all isDigit arg) 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
      wcsr = map (checkLine f) (zip [1 ..] ls)
      wcs = map fst wcsr
      wfile = [ Diag (diagLinePos f 2) "windows (CRLF) file" ]
      noNL = not $ isSuffixOf "\n" str
      cs = case group $ map fst wcs of
             [True : _, [False]] | noNL -> wfile -- with missing newline
             x : _ : _ ->
               [ Diag (diagLinePos f (length x + 1))
                 "inconsistent unix (LF) or windows (CRLF) file" ]
             [True : _] -> wfile
             _ -> []
        ++ concatMap snd wcs ++ checkBlankLines f 0 0 ls
      newStr = unlines $ map snd wcsr
      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)"
    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 -- ^ 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
  [] -> [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
    else [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines"
         | c > 2 ] ++ checkBlankLines f 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
  [] -> []
  x : r ->
    if p x
    then removeBlankLines (c + 1) p r
    else replicate (min 2 c) [] ++ x : removeBlankLines 0 p 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) -> ((Bool, [Diag]), String)
checkLine f (n, s) =
  let r = reverse s
      (sps, rt) = span isSpace r
      (w, ws) = case sps of
         '\r' : rs -> (True, rs)
         _ -> (False, sps)
      t = reverse rt
      p = diagLinePos f n
      v = untabify p t
      l = length v
      trailBSlash = takeWhile (== '\\') rt
  in ((w,
     [ Diag p $ "too long line (" ++ show l ++ " chars)" | l > 80 ]
  ++ badChars p t
  ++ [ Diag (setSourceColumn p l)
       "back slash at line end (may disturb cpp)"
     | not (null trailBSlash) ]
  ++ [ Diag (setSourceColumn p $ l + 1)
       $ "trailing (" ++ show (length ws) ++ ") white space"
     | not (null ws) ]), v)

-- | 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

{- | 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

-- | replace all tabs by blanks in a string
untabify :: SourcePos -> String -> String
untabify p s = case s of
  "" -> ""
  c : r -> let q = updatePosChar p c in case c of
      '\t' -> replicate (sourceColumn q - sourceColumn p) ' '
      _ -> [c]
    ++ untabify q r