scan-0.1.0.9: 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 (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 System.IO

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.9 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
options :: [OptDescr Flag]
options =
    [ Option "h" ["help"] (NoArg Help)
      "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 . readN) "<n>")
      "report lines longer than <n> (default -l80)"
    , 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 -b2)"
    , 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 -> 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

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 { checkComments = 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
start with a minus sign must follow an "--" option. -}

-- | get arguments, separate options, and process files
main :: IO ()
main = do
  args <- getArgs
  prN <- getProgName
  let (optsOrFiles, files1) = span (/= "--") args
      (flags, files2, errs) = getOpt Permute options optsOrFiles
      files = files2 ++ drop 1 files1
      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
    _ | length (show flags) < 0 -- force evaluation of flags
      -> exitFailure
    file : r -> let
      out = output file flags
      proc = process out (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

readByteFile :: FilePath -> IO String
readByteFile f = openBinaryFile f ReadMode >>= hGetContents

writeByteFile :: FilePath -> String -> IO ()
writeByteFile f = withBinaryFile f WriteMode . flip hPutStr

{- | 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) -> Opts -> FilePath -> IO ()
process out opts f = do
  str <- readByteFile f
  let ls = lines str
      wcsr = map (checkLine (lineLength opts) f) (zip [1 ..] ls)
      wcs = map fst wcsr
      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
             x : _ : _ ->
               [ 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
        ++ 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)
  case parse scan f newStr of
    Right ts -> let (nts, ds) = anaPosToks opts ts in case out of
      Nothing -> prDiags $ cs ++ ds ++ fs
      Just (ofile, mbak) ->
        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
            Nothing -> return ()
            Just bak -> do
              writeByteFile bak str
              putStrLn $ "created backup file: " ++ bak
          writeByteFile ofile rstr
          putStrLn $ "wrote file: " ++ ofile
    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 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 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 any (not . isSpace) s
    then [ Diag p $ "too many (" ++ show c ++ ") consecutive blank lines"
         | c > m ] ++ checkBlankLines f m 0 n1 r
    else checkBlankLines f m (c + 1) n1 r

-- | removing more than two consecutive lists fulfilling the predicate
removeBlankLines :: Int -> Int -> ([a] -> Bool) -> [[a]] -> [[a]]
removeBlankLines m c p l = case l of
  [] -> []
  x : r ->
    if p x
    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
diagLinePos = setSourceLine . initialPos

-- | check length, chars and end of a line
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
         '\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 > ll ]
  ++ 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 -> let f : _ = t in
            (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