version 0.2.0.10.2.0.1

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