packages feed

hstyle 0.1 → 0.2.0.1

raw patch · 7 files changed

+276/−144 lines, 7 filesdep +haskell-src-extsdep +vectordep −haskell98dep ~textnew-uploader

Dependencies added: haskell-src-exts, vector

Dependencies removed: haskell98

Dependency ranges changed: text

Files

hstyle.cabal view
@@ -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
+ src/HStyle.hs view
@@ -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"
+ src/HStyle/Alignment.hs view
@@ -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)
+ src/HStyle/Block.hs view
@@ -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
+ src/HStyle/Checker.hs view
@@ -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)]
+ src/HStyle/Selector.hs view
@@ -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
src/Main.hs view
@@ -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 where--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)-+-- | 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 ---------------------------------------------------------------------------------- | Placeholder for fixing style problems.-fixStyle :: t -> a-fixStyle _ = do-    error "Not implemented"+import Control.Applicative ((<$>))+import System.Environment (getArgs)+import System.Exit (ExitCode (..), exitWith) +import HStyle ------------------------------------------------------------------------------- -- | 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'"