diff options
author | JasperVanDerJeugt <> | 2011-10-28 17:38:05 (GMT) |
---|---|---|
committer | hdiff <hdiff@luite.com> | 2011-10-28 17:38:05 (GMT) |
commit | 0d0b8804aeb0d767de52d89abb7b0581fea87e9a (patch) | |
tree | 609d66216f3366e38e7e726316fe1e0d1029049a | |
parent | d50ff970ec6f851e286b1868308bc8739c15d54d (diff) |
version 0.2.0.10.2.0.1
-rw-r--r-- | hstyle.cabal | 56 | ||||
-rw-r--r-- | src/HStyle.hs | 89 | ||||
-rw-r--r-- | src/HStyle/Alignment.hs | 40 | ||||
-rw-r--r-- | src/HStyle/Block.hs | 64 | ||||
-rw-r--r-- | src/HStyle/Checker.hs | 20 | ||||
-rw-r--r-- | src/HStyle/Selector.hs | 18 | ||||
-rw-r--r-- | src/Main.hs | 133 |
7 files changed, 276 insertions, 144 deletions
diff --git a/hstyle.cabal b/hstyle.cabal index 283e520..c65e00b 100644 --- a/hstyle.cabal +++ b/hstyle.cabal @@ -1,36 +1,40 @@ -name: hstyle -version: 0.1 -synopsis: Checks Haskell source code for style compliance. -description: Originally intended to automate style checking for the Snap +Name: hstyle +Version: 0.2.0.1 +Synopsis: Checks Haskell source code for style compliance. +Description: Originally intended to automate style checking for the Snap project. But the project should be general enough to work with other style guides. -license: BSD3 -license-file: LICENSE -author: Doug Beardsley -maintainer: mightybyte@mightybyte.net -build-type: Simple -cabal-version: >= 1.6 -category: Development +License: BSD3 +License-file: LICENSE +Author: Doug Beardsley <mightybyte@mightybyte.net> + Jasper Van der Jeugt <m@jaspervdj.be> +Maintainer: Doug Beardsley <mightybyte@mightybyte.net> + Jasper Van der Jeugt <m@jaspervdj.be> +Build-type: Simple +Cabal-version: >= 1.6 +Category: Development -extra-source-files: +Extra-source-files: README.md - + Executable hstyle - hs-source-dirs: src - main-is: Main.hs + Hs-source-dirs: src + Main-is: Main.hs + Ghc-options: -Wall - build-depends: - base >= 4 && < 5, - haskell98, - text + Other-modules: + HStyle + HStyle.Alignment + HStyle.Block + HStyle.Checker + HStyle.Selector - if impl(ghc >= 6.12.0) - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans -fno-warn-unused-do-bind - else - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields - -fno-warn-orphans + Build-depends: + base >= 4 && < 5, + haskell-src-exts >= 1.11 && < 1.12, + text >= 0.11 && < 0.12, + vector >= 0.7 && < 0.8 -source-repository head +Source-repository head type: git location: http://github.com/mightybyte/hstyle diff --git a/src/HStyle.hs b/src/HStyle.hs new file mode 100644 index 0000000..33f7f8d --- /dev/null +++ b/src/HStyle.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +module HStyle + ( checkStyle + , fixStyle + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (forM, forM_) +import Data.Char (isSpace) + +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Language.Haskell.Exts.Annotated as H + +import HStyle.Alignment +import HStyle.Block +import HStyle.Selector +import HStyle.Checker + +-- | A selector and a check... +type Rule = (Selector, Checker) + +runRule :: FilePath -> Block -> H.Module H.SrcSpanInfo -> Rule -> IO Bool +runRule file block md (selector, check) = fmap and $ + forM (selector md block) $ \block' -> do + let problems = check block' + forM_ problems $ \(i, problem) -> do + let line = absoluteLineNumber i block' + T.putStrLn $ T.pack file `T.append` ":" `T.append` + T.pack (show line) `T.append` ": " `T.append` problem + T.putStrLn "" + T.putStr $ prettyBlock 4 block' + T.putStrLn "" + return $ null problems + +fromSrcSpanInfo :: H.SrcSpanInfo -> Block -> Block +fromSrcSpanInfo ssi = subBlock start end + where + span' = H.srcInfoSpan ssi + start = H.srcSpanStartLine span' + end = H.srcSpanEndLine span' + +typeSigSelector :: Selector +typeSigSelector md block = map (flip fromSrcSpanInfo block) $ tss md + where + tss (H.Module _ _ _ _ decls) = [ssi | H.TypeSig ssi _ _ <- decls] + tss _ = [] + +typeSigCheck :: Checker +typeSigCheck block = case checkAlignmentHead alignment of + Just t -> [(1, t)] + Nothing -> [] + where + alignment = alignmentOf ["::", "=>", "->"] $ toLines block + +tabsCheck :: Checker +tabsCheck = checkLines $ \line -> case T.findIndex (== '\t') line of + Nothing -> Nothing + Just i -> Just $ "\\t at column " `T.append` T.pack (show $ i + 1) + +lineLengthCheck :: Int -> Checker +lineLengthCheck max' = checkLines $ \line -> if T.length line > max' + then Just $ "exceeds max line length of " `T.append` T.pack (show max') + else Nothing + +trailingWhiteSpace :: Checker +trailingWhiteSpace = checkLines $ \line -> + if not (T.null line) && isSpace (T.last line) + then Just "trailing whitespace" + else Nothing + +checkStyle :: FilePath -> IO Bool +checkStyle file = do + contents <- readFile file + let block = fromText $ T.pack contents + case H.parseModule contents of + H.ParseOk md -> and <$> mapM (runRule file block md) + [ (typeSigSelector, typeSigCheck) + , (selectLines, tabsCheck) + , (selectLines, lineLengthCheck 78) + , (selectLines, trailingWhiteSpace) + ] + err -> do + putStrLn $ "HStyle.checkStyle: could not parse " ++ + file ++ ": " ++ show err + return False + +fixStyle :: FilePath -> IO () +fixStyle = error "HStyle.fixStyle: Not implemented" diff --git a/src/HStyle/Alignment.hs b/src/HStyle/Alignment.hs new file mode 100644 index 0000000..dd81382 --- /dev/null +++ b/src/HStyle/Alignment.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module HStyle.Alignment where + +import Data.List (find, nub) +import Data.Text (Text) +import qualified Data.Text as T + +type Lines = [Text] +type Alignment = [[(Int, Text)]] + +-- This is a really really long comment and I'm not sure if this is a good idea cause it might not fit on one line +checkAlignmentHead :: Alignment + -> Maybe Text +checkAlignmentHead alignment + | null alignment' = Nothing + | equal (map fst heads) = Nothing + | otherwise = Just $ "improper alignment of " `T.append` + T.pack (show $ nub $ map snd heads) + where + alignment' = filter (not . null) alignment + heads = map head alignment' + +equal :: Eq a + => [a] + -> Bool +equal (x : y : r) + | x == y = equal (y : r) + | otherwise = False +equal _ = True + +alignmentOf :: [Text] -> Lines -> Alignment +alignmentOf xs = map $ alignmentOf' 0 + where + alignmentOf' i t + | T.null t = [] + | otherwise = case find (`T.isPrefixOf` t) xs of + Nothing -> alignmentOf' (i + 1) (T.drop 1 t) + Just x -> + let len = T.length x + in (i, x) : alignmentOf' (i + len) (T.drop len t) diff --git a/src/HStyle/Block.hs b/src/HStyle/Block.hs new file mode 100644 index 0000000..2fe38a2 --- /dev/null +++ b/src/HStyle/Block.hs @@ -0,0 +1,64 @@ +-- | A block of code +{-# LANGUAGE OverloadedStrings #-} +module HStyle.Block + ( Block + , fromText + , prettyBlock + , toLines + , subBlock + , perLine + , absoluteLineNumber + ) where + +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Text as T + +data Block = Block + { blockOffset :: Int + , blockLines :: Vector Text + } deriving (Show) + +fromText :: Text -> Block +fromText text = Block + { blockOffset = 0 + , blockLines = V.fromList $ T.lines text + } + +prettyBlock :: Int -> Block -> Text +prettyBlock indent block = T.unlines $ + map ((T.replicate indent " " `T.append`) . pretty) $ + zip [offset + 1 ..] $ V.toList lines' + where + offset = blockOffset block + lines' = blockLines block + width = length $ show (offset + V.length lines') + + pretty (ln, t) = + let ln' = T.pack (show ln) + lnl = T.length ln' + in T.replicate (width - lnl) " " `T.append` + ln' `T.append` " " `T.append` t + +toLines :: Block -> [Text] +toLines = V.toList . blockLines + +-- | Subblock from start to end -- including both. +subBlock :: Int -> Int -> Block -> Block +subBlock start end block = Block + { blockOffset = blockOffset block + start - 1 + , blockLines = V.slice (start - 1) (end - start + 1) $ blockLines block + } + +-- | Create a new block for every line. +perLine :: Block -> [Block] +perLine (Block offset lines') = map line $ + zip [offset + 0 ..] $ V.toList lines' + where + line (i, t) = Block i $ V.singleton t + +-- | Convert relative line number (within this block, 1-based) to an absolute +-- line number +absoluteLineNumber :: Int -> Block -> Int +absoluteLineNumber i = (+ i) . blockOffset diff --git a/src/HStyle/Checker.hs b/src/HStyle/Checker.hs new file mode 100644 index 0000000..684f15d --- /dev/null +++ b/src/HStyle/Checker.hs @@ -0,0 +1,20 @@ +module HStyle.Checker + ( Checker + , checkLines + ) where + +import Data.Text (Text) + +import HStyle.Block + +-- | Takes a number of lines, and notifies of problems on each line. Indices +-- in the result are 1-based. +type Checker = Block -> [(Int, Text)] + +-- | Check every line of the block, possibly returning a problem description +checkLines :: (Text -> Maybe Text) -> Checker +checkLines checker block = do + (ln, text) <- zip [1 ..] (toLines block) + case checker text of + Nothing -> [] + Just p -> [(ln , p)] diff --git a/src/HStyle/Selector.hs b/src/HStyle/Selector.hs new file mode 100644 index 0000000..361ab4e --- /dev/null +++ b/src/HStyle/Selector.hs @@ -0,0 +1,18 @@ +module HStyle.Selector + ( Selector + , selectAll + , selectLines + ) where + +import Language.Haskell.Exts.Annotated (Module, SrcSpanInfo) + +import HStyle.Block + +-- | Selects a portion from a haskell module +type Selector = Module SrcSpanInfo -> Block -> [Block] + +selectAll :: Selector +selectAll _ = return + +selectLines :: Selector +selectLines _ = perLine diff --git a/src/Main.hs b/src/Main.hs index 5e0654f..4a8a4d3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,127 +1,24 @@ -{-| +-- | This is a very simple project containing a few code style checks for use +-- in git hooks for the Snap Framework. Hopefully we'll get some more +-- sophisticated checks and automatic fixes implemented eventually. +module Main + ( main + ) where -This is a very simple project containing a few code style checks for use in -git hooks for the Snap Framework. Hopefully we'll get some more sophisticated -checks and automatic fixes implemented eventually. +import Control.Applicative ((<$>)) +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitWith) --} -module Main where +import HStyle -import System - -import qualified Data.Text as T -import qualified Data.Text.IO as TI -import Data.Text (Text) - - ------------------------------------------------------------------------------- --- | A check is a function that processes a Text and returns a Just String if --- there is a problem. -type Check = Text -> Maybe String - - ------------------------------------------------------------------------------- --- | A problem consists of a line number and a string description. -data Problem = Problem { - probLine :: Int, - probDescription :: String -} - - ------------------------------------------------------------------------------- --- Style checks ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- | Checks for trailing spaces on a line. -trailingSpaces :: Check -trailingSpaces line = if T.length (T.takeWhile (==' ') $ T.reverse line) == 0 - then Nothing - else Just "Line has trailing spaces" - - ------------------------------------------------------------------------------- --- | Checks for tab charcters anywhere on a line. -noTabs :: Check -noTabs line = fmap (const "Line contains tab(s).") $ T.find (=='\t') line - - ------------------------------------------------------------------------------- --- | Ensures line length is 78 characters or less. -lineLength :: Int -> Check -lineLength n line = - if T.length line <= n - then Nothing - else Just "Line too long" - - ------------------------------------------------------------------------------- --- | Static list of line-oriented checks to use. -lineChecks :: [Check] -lineChecks = [lineLength 78, noTabs, trailingSpaces] - - ------------------------------------------------------------------------------- --- Infrastructure ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- | Applies a list of checks to a list of lines. Returns a list of --- 'Problem's. -onLines :: [Check] -> [Text] -> [Problem] -onLines fs thelines = concat $ map (go 1 thelines) fs - where - go _ [] _ = [] - go num (l:ls) f = case f l of - Nothing -> go (num+1) ls f - Just er -> (Problem num er) : go (num+1) ls f - - ------------------------------------------------------------------------------- --- | Breaks a file into lines and runs all the checks on them. -checkContents :: Text -> [Problem] -checkContents c = lineChecks `onLines` (T.lines c) - - ------------------------------------------------------------------------------- --- | Runs checks on the specified file. -checkFile :: FilePath -> IO (FilePath, [Problem]) -checkFile f = do - problems <- return . checkContents =<< TI.readFile f - return (f,problems) - - ------------------------------------------------------------------------------- --- | Checks the style of a list of files, prints the problems, and exits with --- a return value appropriate for use in a git hook. -checkStyle :: [FilePath] -> IO () -checkStyle fs = do - results <- mapM checkFile fs - mapM_ printResults results - case results of - [] -> exitWith ExitSuccess - _ -> exitWith (ExitFailure 1) - where - printResults (f,ps) = mapM_ (printRes f) ps - printRes f p = putStrLn $ f ++ " line " ++ (show $ probLine p) ++ - ": " ++ (probDescription p) - - ------------------------------------------------------------------------------- --- | Placeholder for fixing style problems. -fixStyle :: t -> a -fixStyle _ = do - error "Not implemented" - - ------------------------------------------------------------------------------- -- | Simple main that takes one command-line parameter of "check" or "fix" and -- a list of files to be checked. main :: IO () main = do args <- getArgs case args of - "check":files -> checkStyle files - "fix":files -> fixStyle files - _ -> error "Must specify 'check' or 'fix'" - + "check" : files -> do + ok <- and <$> mapM checkStyle files + exitWith $ if ok then ExitSuccess else ExitFailure 1 + "fix" : files -> mapM_ fixStyle files + _ -> error "Must specify 'check' or 'fix'" |