summaryrefslogtreecommitdiff
path: root/src/HStyle.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/HStyle.hs')
-rw-r--r--src/HStyle.hs89
1 files changed, 89 insertions, 0 deletions
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"