scan 0.1.0.1 → 0.1.0.2
raw patch · 3 files changed
+193/−124 lines, 3 files
Files
- scan.cabal +1/−1
- src/Language/Haskell/Scanner.hs +109/−85
- src/scan.hs +83/−38
scan.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: scan-version: 0.1.0.1+version: 0.1.0.2 license: BSD3 license-file: doc/LICENSE category: Development
src/Language/Haskell/Scanner.hs view
@@ -15,10 +15,14 @@ module Language.Haskell.Scanner ( splitLines+ , splitBy , showScan , processScan , scan , PosTok+ , Diag (..)+ , showDiag+ , showSourcePos ) where import Control.Monad@@ -118,52 +122,59 @@ hChar :: Parser Char hChar = alphaNum <|> oneOf "_'" --- | the underscore parser-uL :: Parser Char-uL = char '_'- -- | lower case identifiers (aka variables) lId :: Parser String-lId = (uL <|> lower) <:> many hChar+lId = (char '_' <|> lower) <:> many hChar -- | upper case identifiers (aka constructors) uId :: Parser String uId = upper <:> many hChar -- | any character within operators-opSym :: Parser Char-opSym = oneOf "!#$%&*+-./:<=>?@\\^|~"+opSym :: Char -> Bool+opSym c = elem c "!#$%&*+-./:<=>?@\\^|~"+ || not (isAscii c) && (isSymbol c || isPunctuation c) -- | any operator (mainly infixes) operator :: Parser String-operator = many1 opSym+operator = many1 $ satisfy opSym -- | possible qualified entities: lower or upper case words or symbols-data QualElem = Var | Cons | Sym deriving Eq+data QualElem = Var | Cons | Sym -- | a name qualified or not with its representation data QualName = Name Bool QualElem String --- | the show instance renders the original string-instance Show QualName where- show (Name _ _ s) = s+-- | the original string+showQualName :: QualName -> String+showQualName (Name _ _ s) = s --- | any qualified or unqualified name or operator+-- | the possible characters starting a name+qIdStart :: Parser Char+qIdStart = satisfy $ \ c -> c == '_' || isLetter c || opSym c++-- | any quoted, qualified, or unqualified name or operator qId :: Parser QualName qId = fmap (Name False Var) lId <|> fmap (Name False Sym) operator <|> do n <- uId option (Name False Cons n) $ do- d <- try (char '.' << lookAhead (uL <|> letter <|> opSym))+ d <- try (char '.' << lookAhead qIdStart) Name _ k r <- qId return $ Name True k $ n ++ d : r+ <|> do+ let noCh = notFollowedBy (char '\'')+ s <- try (string "'" << lookAhead (letter << noCh)) -- limited recognition+ <|> try (string "''" << noCh)+ Name b k r <- qId+ return $ Name b k $ s ++ r -- | parse any 'qId' within back ticks. This is more liberal than haskell! infixOp :: Parser String-infixOp = enclosedBy (fmap show qId) $ char '`'+infixOp = enclosedBy (fmap showQualName qId) $ char '`' --- | the separators are comma, semicolon and various kinds of parens+-- | the separators are newline, comma, semicolon and three kinds of parens seps :: String seps = "[({,;})]\n" @@ -177,10 +188,10 @@ | Token TokenKind String | Start -- ^ the void token at the very beginning --- | the show instance renders the original string without kind information-instance Show Token where- show t = case t of- QualName q -> show q+-- | renders the original string without kind information+showToken :: Token -> String+showToken t = case t of+ QualName q -> showQualName q Sep c -> [c] Token _ s -> s Start -> ""@@ -193,20 +204,26 @@ white :: Parser String white = many $ satisfy isWhite +-- | a literal followed by up to two (one for 'charLit') optional magic hashes+literal :: Parser String+literal = let optH = optionL (string "#") in+ charLit <++> optH+ <|> (stringLit <|> number) <++> optionL (char '#' <:> optH)+ -- | parse any non-white token tok :: Parser Token tok = fmap (Token BlockComment) nestComment <|> fmap (Token LineComment) lineComment <|> fmap QualName qId <|> fmap Sep (oneOf seps)- <|> fmap (Token Literal) (charLit <|> stringLit <|> number)+ <|> fmap (Token Literal) literal <|> fmap (Token Infix) infixOp -- | tokens enriched by positions and following white space data PosTok = PosTok SourcePos Token String -instance Show PosTok where- show (PosTok _ t s) = shows t s+showPosTok :: PosTok -> String+showPosTok (PosTok _ t s) = showToken t ++ s -- | attach positions and subsequent 'white' spaces to tokens posTok :: Parser PosTok@@ -228,7 +245,7 @@ scan :: Parser [PosTok] scan = startTok <:> many posTok << eof --- * splitting lines+-- * splitting and removing {- | a generic splitting function that keeps the separator as first element except in the first list. -}@@ -237,10 +254,6 @@ [] -> [] d : tl -> let hd : tll = splitBy p tl in (d : hd) : tll --- | split lines at newline tokens-splitLines :: [PosTok] -> [[PosTok]]-splitLines = splitBy isIndent- -- | removing more than two consecutive lists fulfilling the predicate removeBlankLines :: Int -> ([a] -> Bool) -> [[a]] -> [[a]] removeBlankLines c p l = case l of@@ -257,60 +270,65 @@ -- | messages with positions data Diag = Diag SourcePos String -instance Show Diag where- show (Diag p s) = show p ++ ' ' : s+showSourcePos :: SourcePos -> String+showSourcePos p = sourceName p ++ ":" ++ shows (sourceLine p) ":"+ ++ shows (sourceColumn p) ":" --- * checking tokens+showDiag :: Diag -> String+showDiag (Diag p s) = showSourcePos p ++ ' ' : s --- | only show the token without spaces-showTok :: PosTok -> String-showTok (PosTok _ t _) = show t+-- * checking tokens -isInfixOp :: PosTok -> Bool-isInfixOp (PosTok _ t _) = case t of+isInfixOp :: Token -> Bool+isInfixOp t = case t of QualName (Name _ Sym s) -> notElem s $ map (: []) "!#@\\~" Token Infix _ -> True _ -> False -isComment :: PosTok -> Bool-isComment (PosTok _ t _) = case t of+isComment :: Token -> Bool+isComment t = case t of Token k _ -> case k of LineComment -> True BlockComment -> True _ -> False _ -> False -noLineComment :: PosTok -> Bool-noLineComment (PosTok _ t _) = case t of+noLineComment :: Token -> Bool+noLineComment t = case t of Token LineComment _ -> False _ -> True -isSepIn :: String -> PosTok -> Bool-isSepIn cs (PosTok _ t _) = case t of+isSepIn :: String -> Token -> Bool+isSepIn cs t = case t of Sep c -> elem c cs _ -> False -isIndent :: PosTok -> Bool+isIndent :: Token -> Bool isIndent = isSepIn "\n" -isOpPar :: PosTok -> Bool+isLineBreak :: PosTok -> Bool+isLineBreak (PosTok _ t _) = isIndent t++isOpPar :: Token -> Bool isOpPar = isSepIn "[({" -isClPar :: PosTok -> Bool+isClPar :: Token -> Bool isClPar = isSepIn "})]" -isOpParOrInfix :: PosTok -> Bool+isOpParOrInfix :: Token -> Bool isOpParOrInfix t = isOpPar t || isInfixOp t -isClParOrInfix :: PosTok -> Bool+isClParOrInfix :: Token -> Bool isClParOrInfix t = isClPar t || isInfixOp t -isNonPar :: PosTok -> Bool+isNonPar :: Token -> Bool isNonPar = isSepIn ",;" -isFstInfixMinusArg :: PosTok -> Bool-isFstInfixMinusArg t@(PosTok _ u _) = case u of- QualName (Name _ k _) -> k /= Sym+isFstInfixMinusArg :: Token -> Bool+isFstInfixMinusArg t = case t of+ QualName (Name _ k _) -> case k of+ Sym -> False+ _ -> True Sep _ -> isClPar t Token k _ -> case k of Literal -> True@@ -318,13 +336,13 @@ _ -> False Start -> False -noSpaceNeededBefore :: PosTok -> Bool+noSpaceNeededBefore :: Token -> Bool noSpaceNeededBefore t =- isSepIn ",;})]" t || showTok t == "@"+ isSepIn ",;})]" t || showToken t == "@" -noSpaceNeededAfter :: PosTok -> Bool-noSpaceNeededAfter t@(PosTok _ u _) =- isOpPar t || elem (show u) (map (: []) "!#-@~")+noSpaceNeededAfter :: Token -> Bool+noSpaceNeededAfter t =+ isOpPar t || elem (showToken t) (map (: []) "!#-@~") -- * adjusting tokens @@ -336,7 +354,8 @@ in replicate bs ' ' untab :: PosTok -> PosTok-untab (PosTok p t w) = PosTok p t $ untabify (updatePosString p $ show t) w+untab (PosTok p t w) =+ PosTok p t $ untabify (updatePosString p $ showToken t) w -- | remove trailing spaces rmSp :: PosTok -> PosTok@@ -348,7 +367,8 @@ multipleBlanks :: PosTok -> [Diag] multipleBlanks (PosTok p t w) = let n = length w in- [ Diag (updatePosString p $ show t) $ "multiple (" ++ show n ++ ") blanks"+ [ Diag (updatePosString p $ showToken t)+ $ "multiple (" ++ show n ++ ") blanks" | n > 1 ] -- | tidy up line comments@@ -407,7 +427,7 @@ [ Diag p $ "non-conventional comment start: " ++ s5 | s5 /= take 5 n ] ++ [ Diag (updatePosString p s) $ "non-conventional comment end: " ++ reverse sr | sr /= nr ])- _ | show u == ";" -> (t, [Diag p "use layout instead of ;"])+ _ | showToken u == ";" -> (t, [Diag p "use layout instead of ;"]) _ -> (t, []) anaLine :: [PosTok] -> ([PosTok], [Diag])@@ -425,61 +445,61 @@ t2@(PosTok p2 u2 w2) : r2 -> case u1 of Start -> (rmSp t1, cs ++ [Diag p1 "leading white space" | not (null w1)]) <+> anaLine r1- _ | isIndent t1 -> let (ft, rt) = span (== ' ') w1 in+ _ | isIndent u1 -> let (ft, rt) = span (== ' ') w1 in (untab t1, cs ++ [ Diag (updatePosString p1 ft) "use only blanks for indentation" | not (null rt) ]) <+> anaLine r1 _ -> let- s1 = show u1- s2 = show u2+ s1 = showToken u1+ s2 = showToken u2 n1 = length s1 n2 = length s2 lt = n1 <= n2 both = s1 ++ s2 after = case () of- _ | isNonPar t1 -> True- | isOpPar t2 -> False+ _ | isNonPar u1 -> True+ | isOpPar u2 -> False | s1 == "\\" -> True- | isInfixOp t1 -> if isInfixOp t2 then lt else True- | isInfixOp t2 || s2 == ".." -> False+ | isInfixOp u1 -> if isInfixOp u2 then lt else True+ | isInfixOp u2 || s2 == ".." -> False _ -> lt parsOfBoth = filter (`elem` "[({})]") both pos = case both of _ : _ : _ -> "between"- _ | isOpPar t1 -> "after"- | isClPar t2 -> "before"+ _ | isOpPar u1 -> "after"+ | isClPar u2 -> "before" _ -> "here"- omitSpace = isOpParOrInfix t1 && isClParOrInfix t2- && not (isInfixOp t1 && isInfixOp t2)+ omitSpace = isOpParOrInfix u1 && isClParOrInfix u2+ && not (isInfixOp u1 && isInfixOp u2) && (s1 /= ".." || s2 /= "]")- addSpace = not (noSpaceNeededAfter t1)- && not (noSpaceNeededBefore t2)+ addSpace = not (noSpaceNeededAfter u1)+ && not (noSpaceNeededBefore u2) (newT1, ds) = if null w1 then if addSpace then (blank t1, Diag p2 ("leave space " ++ if after then "after " ++ s1 else "before " ++ s2)- : [ Diag p1 "but may be template haskell splice $("- | both == "$(" ])+ : [ Diag p1 $ "may be template haskell " ++ both+ | s1 == "$" ]) else (t1, []) else if omitSpace then (rmSp t1,- [Diag p2 $ " no space needed " ++ pos ++ " " ++ parsOfBoth])- else if isComment t2+ [Diag p2 $ "no space needed " ++ pos ++ " " ++ parsOfBoth])+ else if isComment u2 then (untab t1, []) else (blank t1, multipleBlanks t1) pt0 = (newT1, cs ++ ds) in case r2 of [] -> pt0 <+> anaLine r1- t3@(PosTok _ u3 _) : _ -> let- s3 = show u3+ PosTok _ u3 _ : _ -> let+ s3 = showToken u3 ms = [Diag p2 "put spaces around infix -" | null w1 || null w2 ] ++ multipleBlanks t1 ++ multipleBlanks t2- in if s2 == "-" && not (noSpaceNeededBefore t3)- && isFstInfixMinusArg t1+ in if s2 == "-" && not (noSpaceNeededBefore u3)+ && isFstInfixMinusArg u1 then (blank t1, cs ++ ms) <+> anaLine (blank t2 : r2)- else (if elem s2 ["do", "of"] && s3 /= "{" && noLineComment t3+ else (if elem s2 ["do", "of"] && s3 /= "{" && noLineComment u3 then (newT1, cs ++ Diag p2 ("break line after " ++ show s2) : ds) else pt0) <+> anaLine r1@@ -489,7 +509,7 @@ isBlankLine :: [PosTok] -> Bool isBlankLine x = case x of [PosTok _ Start _] -> True- [t] -> isIndent t+ [t] -> isLineBreak t _ -> False removeFinalBlankLines :: [[PosTok]] -> [[PosTok]]@@ -498,11 +518,15 @@ -- * main functions +-- | split lines at newline tokens+splitLines :: [PosTok] -> [[PosTok]]+splitLines = splitBy isLineBreak+ -- | create adjusted source file processScan :: [[PosTok]] -> String-processScan = concatMap (concatMap show . fst . anaLine)+processScan = concatMap (concatMap showPosTok . fst . anaLine) . removeBlankLines 1 isBlankLine . removeFinalBlankLines -- | list all diagnostics-showScan :: [[PosTok]] -> String-showScan = intercalate "\n" . concatMap (map show . snd . anaLine)+showScan :: [[PosTok]] -> [Diag]+showScan = concatMap (snd . anaLine)
src/scan.hs view
@@ -11,7 +11,7 @@ the Haskell style scanner -} -module Main where+module Main () where import Control.Monad @@ -19,66 +19,111 @@ 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 (opts, files) = span (== "-") args- b = null opts- case files of- [] -> putStrLn "missing file argument"- _ -> mapM_ (process $ null opts) $ if b then files else- take 3 files -- do not spoil more than 3 files+ 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 :: Bool -> String -> IO ()+{- | 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 nls = zip [1 ..] $ lines str- bls = checkBlankLines f 1 nls- when b $ mapM_ (checkLine f) nls- when (b && not (isSuffixOf "\n" str))- $ diag f (length nls) "missing final newline"- when b $ mapM_ putStrLn bls+ 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 o = showScan x in unless (null o) $ putStrLn o else+ 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 -> fail $ show err+ Left err -> do+ prDiags cs+ putStrLn $ showParseError err+ exitFailure -checkBlankLines :: FilePath -> Int -> [(Int, String)] -> [String]-checkBlankLines f c l = case l of- [] -> ["trailing blank lines" | c > 0]- (n, s) : r ->+-- | 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- diagStr f n "too many consecutive blank lines"- : checkBlankLines f (- 100) r- else checkBlankLines f (c + 1) r- else checkBlankLines f 0 r--diagStr :: FilePath -> Int -> String -> String-diagStr f n str = "\"" ++ f ++ "\" (line " ++ show n ++ ") " ++ str+ 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 -diag :: FilePath -> Int -> String -> IO ()-diag f n = putStrLn . diagStr f n+-- | create a position from a file and a line number+diagLinePos :: FilePath -> Int -> SourcePos+diagLinePos = setSourceLine . initialPos -checkLine :: FilePath -> (Int, String) -> IO ()-checkLine f (n, s) = do+-- | 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- badChars = filter (\ c -> not $ isAscii c && isPrint c) s- when (l > 80) $- diag f n $ "too long line (" ++ show l ++ " chars)"- unless (null badChars) $- diag f n $ "contains undesirable characters: " ++ show badChars- unless (null trailBSlash) $- diag f n "back slash at line end (may disturb cpp)"+ 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