summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasperVanDerJeugt <>2011-10-28 17:38:05 (GMT)
committerhdiff <hdiff@luite.com>2011-10-28 17:38:05 (GMT)
commit0d0b8804aeb0d767de52d89abb7b0581fea87e9a (patch)
tree609d66216f3366e38e7e726316fe1e0d1029049a
parentd50ff970ec6f851e286b1868308bc8739c15d54d (diff)
version 0.2.0.10.2.0.1
-rw-r--r--hstyle.cabal56
-rw-r--r--src/HStyle.hs89
-rw-r--r--src/HStyle/Alignment.hs40
-rw-r--r--src/HStyle/Block.hs64
-rw-r--r--src/HStyle/Checker.hs20
-rw-r--r--src/HStyle/Selector.hs18
-rw-r--r--src/Main.hs133
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'"