homplexity 0.4.4.1 → 0.4.4.2
raw patch · 23 files changed
+1123/−1110 lines, 23 filesdep ~basedep ~containersdep ~cpphsPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, containers, cpphs, deepseq, directory, filepath, haskell-src-exts, hflags, template-haskell, uniplate
API changes (from Hackage documentation)
Files
- Homplexity.hs +0/−107
- Language/Haskell/Homplexity/Assessment.hs +0/−164
- Language/Haskell/Homplexity/CodeFragment.hs +0/−182
- Language/Haskell/Homplexity/Comments.hs +0/−104
- Language/Haskell/Homplexity/Cyclomatic.hs +0/−105
- Language/Haskell/Homplexity/Message.hs +0/−130
- Language/Haskell/Homplexity/Metric.hs +0/−58
- Language/Haskell/Homplexity/Parse.hs +0/−81
- Language/Haskell/Homplexity/SrcSlice.hs +0/−81
- Language/Haskell/Homplexity/TypeComplexity.hs +0/−77
- README.md +4/−1
- app/Homplexity.hs +107/−0
- changelog.md +4/−0
- homplexity.cabal +24/−20
- lib/Language/Haskell/Homplexity/Assessment.hs +164/−0
- lib/Language/Haskell/Homplexity/CodeFragment.hs +182/−0
- lib/Language/Haskell/Homplexity/Comments.hs +104/−0
- lib/Language/Haskell/Homplexity/Cyclomatic.hs +105/−0
- lib/Language/Haskell/Homplexity/Message.hs +132/−0
- lib/Language/Haskell/Homplexity/Metric.hs +58/−0
- lib/Language/Haskell/Homplexity/Parse.hs +81/−0
- lib/Language/Haskell/Homplexity/SrcSlice.hs +81/−0
- lib/Language/Haskell/Homplexity/TypeComplexity.hs +77/−0
− Homplexity.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--- | Main module parsing inputs, and running analysis.-module Main (main) where--import Data.Functor-import Data.List-import Data.Monoid--import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts.Syntax-import Language.Haskell.Homplexity.Assessment-import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.Message-import Language.Haskell.Homplexity.Parse-import System.Directory-import System.Exit-import System.FilePath-import System.IO--import HFlags---- * Command line flag-defineFlag "severity" Warning (concat ["level of output verbosity (", severityOptions, ")"])---- | Report to standard error output.-report :: String -> IO ()-report = hPutStrLn stderr---- * Recursing directory tree in order to list Haskell source files.--- | Find all Haskell source files within a given path.--- Recurse down the tree, if the path points to directory.-subTrees :: FilePath -> IO [FilePath]--- Recurse to . or .. only at the first level, to prevent looping:-subTrees dir | dir `elem` [".", ".."] = concatMapM subTrees' =<< getDirectoryPaths dir-subTrees filepath = do- isDir <- doesDirectoryExist filepath- if isDir- then subTrees' filepath- else do- exists <- doesFileExist filepath- if exists- then return [filepath]- else do report $ "File does not exist: " ++ filepath- return []---- | Return filepath if normal file, or recurse down the directory if it is not special directory ("." or "..")-subTrees' :: FilePath -> IO [FilePath]-subTrees' (takeFileName -> "..") = return []-subTrees' (takeFileName -> "." ) = return []-subTrees' fp = do- isDir <- doesDirectoryExist fp- if isDir- then concatMapM subTrees' =<< getDirectoryPaths fp- else return $ filter (".hs" `isSuffixOf`) [fp]---- | Get contents of a given directory, and return their full paths.-getDirectoryPaths :: FilePath -> IO [FilePath]-getDirectoryPaths dirPath = map (dirPath </>) <$> getDirectoryContents dirPath---- | Commonly defined function - should be added to base...-concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]-concatMapM f = fmap concat . mapM f---- * Analysis--- | Analyze a set of modules.-analyzeModule :: Module SrcLoc -> IO ()-analyzeModule = putStr- . concatMap show- . extract flags_severity- . mconcat metrics- . program- . (:[])---- | Process each separate input file.-processFile :: FilePath -> IO Bool-processFile filepath = do src <- parseSource filepath- case src of- Left msg -> do report $ show msg- return False- Right (ast, _comments) -> do analyzeModule ast- return True---- | This flag exists only to make sure that HFLags work.-defineFlag "fakeFlag" Info "this flag is fake"---- | Parse arguments and either process inputs (if available), or suggest proper usage.-main :: IO ()-main = do- args <- $initHFlags "Homplexity - automatic analysis of Haskell code quality"- if null args- then do report ("Use Haskell source file or directory as an argument, " ++- "or use --help to discover options.")- exitFailure- else do sums <- mapM processFile =<< concatMapM subTrees args- putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums,- "out of", show $ length sums,- "input files."]-
− Language/Haskell/Homplexity/Assessment.hs
@@ -1,164 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}--- | Main module parsing inputs, and running analysis.-module Language.Haskell.Homplexity.Assessment (- metrics- --, measureAllOccurs- ) where--import Data.Data-import Data.Monoid--import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.Cyclomatic-import Language.Haskell.Homplexity.Message-import Language.Haskell.Homplexity.Metric-import Language.Haskell.Homplexity.TypeComplexity--import HFlags--{--numFunctions = length- . filter isFunBind- . getModuleDecls--testNumFunctions = (>20)--numFunctionsMsg = "More than 20 functions per module"--numFunctionsSeverity = Warning- -}---- * Showing metric measurements-measureAll :: Metric m c => Assessment m -> (a -> [c]) -> Proxy m -> Proxy c -> a -> Log-measureAll assess generator metricType fragType = mconcat- . map (warnOfMeasure assess metricType fragType)- . generator--measureTopOccurs :: (Data from, Metric m c) => Assessment m -> Proxy m -> Proxy c -> from -> Log-measureTopOccurs assess = measureAll assess occurs----measureAllOccurs :: (CodeFragment c, Metric m c) => Severity -> Proxy m -> Proxy c -> Program -> Log--- | Measure all occurences of a given @CodeFragment@ with a given @Metric@,--- then use @Assessment@ on them and give a list of @Log@ messages.------ Arguments come in the following order:--- 1. @Assessment@ for the value of the @Metric@.--- 2. @Metric@ given as @Proxy@ type.--- 3. @CodeFragment@ given as @Proxy@ type.--- 4. Program containing @CodeFragment@s.-measureAllOccurs :: (Data from, Metric m c) => Assessment m -> Proxy m -> Proxy c -> from -> Log-measureAllOccurs assess = measureAll assess allOccurs---- | Type of functions that convert a @Metric@ into a log message.-type Assessment m = m -> (Severity, String)--warnOfMeasure :: (CodeFragment c, Metric m c) => Assessment m -> Proxy m -> Proxy c -> c -> Log-warnOfMeasure assess metricType fragType c = message severity- ( fragmentLoc c )- (unwords [fragmentName c- ,"has"- ,show result- ,recommendation])- where- (severity, recommendation) = assess result- result = measureFor metricType fragType c---- * Assessments of severity for used @Metric@s.--- ** Module definition checks-defineFlag "moduleLinesWarning" (500 :: Int) "issue warning when module exceeds this number of lines"-defineFlag "moduleLinesCritical" (3000 :: Int) "issue critical when module exceeds this number of lines"--assessModuleLength :: Assessment LOC-assessModuleLength (fromIntegral -> locs)- | locs > flags_moduleLinesWarning = (Warning, "should be kept below " ++- show flags_moduleLinesWarning ++- " lines of code.")- | locs > flags_moduleLinesCritical = (Critical, "this function exceeds " ++- show flags_moduleLinesCritical ++- " lines of code.")- | otherwise = (Info, "" )---- ** Function definition checks--- *** Number of lines of code within function body-defineFlag "functionLinesWarning" (20 :: Int) "issue warning when function exceeds this number of lines"-defineFlag "functionLinesCritical" (40 :: Int) "issue critical when function exceeds this number of lines"--assessFunctionLength :: Assessment LOC-assessFunctionLength (fromIntegral -> locs)- | locs > flags_functionLinesWarning = (Warning, "should be kept below " ++- show flags_functionLinesWarning ++- " lines of code.")- | locs > flags_functionLinesCritical = (Critical, "this function exceeds " ++- show flags_functionLinesCritical ++- " lines of code.")- | otherwise = (Info, "" )----- *** Decision depth of function definition-defineFlag "functionDepthWarning" (4 :: Int) "issue warning when function exceeds this decision depth"-defineFlag "functionDepthCritical" (8 :: Int) "issue critical when function exceeds this decision depth"--assessFunctionDepth :: Assessment Depth-assessFunctionDepth (fromIntegral -> depth)- | depth > flags_functionDepthWarning = (Warning, "should have no more than " ++- show depth ++- " nested conditionals" )- | depth > flags_functionDepthWarning = (Warning, "should never exceed " ++- show depth ++- " nesting levels for conditionals")- | otherwise = (Info, "" )---- *** Cyclomatic complexity of function definition-defineFlag "functionCCWarning" (20::Int) "issue warning when function's cyclomatic complexity exceeds this number"-defineFlag "functionCCCritical" (50::Int) "issue critical when function's cyclomatic complexity exceeds this number"--assessFunctionCC :: Assessment Cyclomatic-assessFunctionCC (fromIntegral -> cy)- | cy > flags_functionCCWarning = (Warning, "should be less than " ++- show flags_functionCCWarning)- | cy > flags_functionCCCritical = (Warning, "must never be as high as " ++- show flags_functionCCCritical)- | otherwise = (Info, "" )---- ** Type signature complexity--- *** Type constructor depth in each type signature-defineFlag "typeConDepthWarning" (6::Int) "issue warning when type constructor depth exceeds this number"-defineFlag "typeConDepthCritical" (9::Int) "issue critical when type constructor depth exceeds this number"--assessTypeConDepth :: Assessment ConDepth-assessTypeConDepth (fromIntegral -> cy)- | cy > flags_typeConDepthWarning = (Warning, "should be less than " ++- show flags_typeConDepthWarning )- | cy > flags_typeConDepthCritical = (Warning, "must never be as high as " ++- show flags_typeConDepthCritical)- | otherwise = (Info, "" )---- *** Number of function arguments mentioned in each type signature-defineFlag "numFunArgsWarning" (5::Int) "issue warning when number of function arguments exceeds this number"-defineFlag "numFunArgsCritical" (9::Int) "issue critical when number of function arguments exceeds this number"--assessNumFunArgs :: Assessment NumFunArgs-assessNumFunArgs (fromIntegral -> cy)- | cy > flags_numFunArgsWarning = (Warning, "should be less than " ++ show flags_numFunArgsWarning )- | cy > flags_numFunArgsCritical = (Warning, "must never reach " ++ show flags_numFunArgsCritical)- | otherwise = (Info, "" )---- * Computing and assessing @Metric@s for all @CodeFragment@.--- | Compute all metrics, and assign severity depending on configured thresholds.-metrics :: [Program -> Log]-metrics = [measureTopOccurs assessModuleLength locT moduleT- ,measureTopOccurs assessFunctionLength locT functionT- ,measureTopOccurs assessFunctionDepth depthT functionT- ,measureTopOccurs assessFunctionCC cyclomaticT functionT- ,measureTopOccurs assessTypeConDepth conDepthT typeSignatureT- ,measureTopOccurs assessNumFunArgs numFunArgsT typeSignatureT]-
− Language/Haskell/Homplexity/CodeFragment.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE UndecidableInstances #-}--- | This module generalizes over types of code fragments--- that may need to be iterated upon and measured separately.-module Language.Haskell.Homplexity.CodeFragment (- CodeFragment (fragmentName, fragmentSlice)- , occurs- , occursOf- , allOccurs- , allOccursOf- , Program (..)- , programT- , program- , Module (..)- , moduleT- , Function (..)- , functionT- , TypeSignature (..)- , typeSignatureT- , fragmentLoc- -- TODO: add ClassSignature- ) where--import Data.Data-import Data.Functor-import Data.Generics.Uniplate.Data-import Data.List-import Data.Maybe-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Homplexity.SrcSlice---- | Program-newtype Program = Program { allModules :: [Module SrcLoc] }- deriving (Data, Typeable, Show)---- | Smart constructor for adding cross-references in the future.-program :: [Module SrcLoc] -> Program-program = Program---- | Proxy for passing @Program@ type as an argument.-programT :: Proxy Program-programT = Proxy---- * Type aliases for type-based matching of substructures--- | Alias for a function declaration-data Function = Function {- functionNames :: [String]- , functionLocations :: [SrcLoc]- , functionRhs :: [Rhs SrcLoc]- , functionBinds :: [Binds SrcLoc]- }- deriving (Data, Typeable, Show)---- | Proxy for passing @Function@ type as an argument.-functionT :: Proxy Function-functionT = Proxy---- ** Type signature of a function--- | Type alias for a type signature of a function as a @CodeFragment@-data TypeSignature = TypeSignature { loc :: SrcLoc- , identifiers :: [Name SrcLoc]- , theType :: Type SrcLoc }- deriving (Data, Typeable, Show)---- | Proxy for passing @Program@ type as an argument.-typeSignatureT :: Proxy TypeSignature-typeSignatureT = Proxy---- ** TODO: class signatures (number of function decls inside)--- | Alias for a class signature-data ClassSignature = ClassSignature- deriving (Data, Typeable)---- TODO: need combination of Fold and Biplate--- Resulting record may be created to make pa---- | Class @CodeFragment@ allows for:--- * both selecting direct or all descendants--- of the given type of object within another structure--- (with @occurs@ and @allOccurs@)--- * naming the object to allow user to distinguish it.------ In order to compute selection, we just need to know which--- @AST@ nodes contain the given object, and how to extract--- this given object from @AST@, if it is there (@matchAST@).:w-class (Show c, Data (AST c), Data c) => CodeFragment c where- type AST c- matchAST :: AST c -> Maybe c- fragmentName :: c -> String- fragmentSlice :: c -> SrcSlice- fragmentSlice = srcSlice---- | First location for each @CodeFragment@ - for convenient reporting.-fragmentLoc :: (CodeFragment c) => c -> SrcLoc-fragmentLoc = getPointLoc- . fragmentSlice--mergeBinds = catMaybes--instance CodeFragment Function where- type AST Function = Decl SrcLoc- matchAST (FunBind _ matches) = Just- Function {..}- where- (functionLocations,- (unName <$>) . take 1 -> functionNames,- functionRhs,- catMaybes -> functionBinds) = unzip4 $ map extract matches- extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds)- matchAST (PatBind (singleton -> functionLocations) pat- (singleton -> functionRhs )- (maybeToList -> functionBinds )) = Just Function {..}- where- functionNames = wildcards ++ map unName (universeBi pat :: [Name SrcLoc])- wildcards = mapMaybe wildcard (universe pat)- where- wildcard PWildCard {} = Just ".."- wildcard _ = Nothing- matchAST _ = Nothing- fragmentName Function {..} = unwords $ "function":functionNames---- | Make a single element list.-singleton :: a -> [a]-singleton = (:[])---- | Direct occurences of given @CodeFragment@ fragment within another structure.-occurs :: (CodeFragment c, Data from) => from -> [c]-occurs = mapMaybe matchAST . childrenBi---- | Explicitly typed variant of @occurs@.-occursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]-occursOf _ = occurs--allOccurs :: (CodeFragment c, Data from) => from -> [c]-allOccurs = mapMaybe matchAST . universeBi---- | Explicitly typed variant of @allOccurs@.-allOccursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]-allOccursOf _ = allOccurs--instance CodeFragment Program where- type AST Program = Program- matchAST = Just- fragmentName _ = "program"--instance CodeFragment (Module SrcLoc) where- type AST (Module SrcLoc)= Module SrcLoc- matchAST = Just - fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) = - "module " ++ theName- fragmentName (Module _ Nothing _ _ _) = - "<unnamed module>"- fragmentName (XmlPage _ (ModuleName _ theName) _ _ _ _ _) = "XML page " ++ theName- fragmentName (XmlHybrid _ (Just (ModuleHead _ (ModuleName _ theName) _ _))- _ _ _ _ _ _ _) = "module with XML " ++ theName- fragmentName (XmlHybrid _ Nothing _ _ _ _ _ _ _ ) = "<unnamed module with XML>"---- | Proxy for passing @Module@ type as an argument.-moduleT :: Proxy (Module SrcLoc)-moduleT = Proxy--instance CodeFragment TypeSignature where- type AST TypeSignature = Decl SrcLoc- matchAST (TypeSig loc identifiers theType) = Just TypeSignature {..}- matchAST _ = Nothing- fragmentName TypeSignature {..} = "type signature for "- ++ intercalate ", " (map unName identifiers)---- | Unpack @Name@ identifier into a @String@.-unName :: Name a -> String-unName (Symbol _ s) = s-unName (Ident _ i) = i -
− Language/Haskell/Homplexity/Comments.hs
@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-module Language.Haskell.Homplexity.Comments (- CommentLink (..)- , CommentType (..)- , classifyComments- , findCommentType -- exposed for testing only- , CommentSite (..)- , commentable-- , orderCommentsAndCommentables- ) where--import Data.Char-import Data.Data-import Data.Function-import Data.Functor-import Data.List--import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.SrcSlice-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts---- | Describes the comment span, and the way it may be connected to the--- source code-data CommentLink = CommentLink { commentSpan :: SrcSpan- , commentType :: CommentType- }- deriving(Eq, Ord, Show)---- | Possible link between comment and commented entity.-data CommentType = CommentsBefore -- ^ May be counted as commenting object that starts just before.- | CommentsInside -- ^ May be counted as commenting object within which it exists.- | CommentsAfter -- ^ May be counted as commenting object that starts just after.- deriving (Eq, Ord, Enum, Show)---- | Classifies all comments in list, so they can be assigned to declarations later.-classifyComments :: [Comment] -> [CommentLink]-classifyComments = map classifyComment- where- classifyComment (Comment _ commentSpan (findCommentType -> commentType)) = CommentLink {..}---- | Finds Haddock markers of which declarations the comment pertains to.-findCommentType :: String -> CommentType-findCommentType txt = case (not . isSpace) `find` txt of- Just '^' -> CommentsBefore- Just '|' -> CommentsAfter- Just '*' -> CommentsInside -- since it comments out the group of declarations, it belongs to the containing object- _ -> CommentsInside---- * Finding ranges of all commentable entities.--- | Tagging of source range for each commentable object.-data CommentSite = CommentSite { siteName :: String- , siteSlice :: SrcSlice- }- deriving (Show)---- | Find comment sites for entire program.-commentable :: Data from => from -> [CommentSite]-commentable code = ($ code) `concatMap` [slicesOf functionT- ,slicesOf typeSignatureT- ,slicesOf moduleT ]- where- commentSite :: CodeFragment c => (c -> SrcSlice) -> c -> CommentSite- commentSite with frag = CommentSite (fragmentName frag)- (with frag)- commentSites :: (CodeFragment c, Data from) => (c -> SrcSlice) -> Proxy c -> from -> [CommentSite]- commentSites with fragType = map (commentSite with) . occursOf fragType- slicesOf :: (CodeFragment c, Data from) => Proxy c -> from -> [CommentSite]- slicesOf = commentSites fragmentSlice - --locsOf = commentSites (locAsSpan . fragmentLoc)---- | Take together are commentable elements, and all comments, and order them by source location.-orderCommentsAndCommentables :: [CommentSite] -> [CommentLink] -> [Either CommentLink CommentSite]-orderCommentsAndCommentables sites comments = sortBy (compare `on` loc) elts- where- loc :: Either CommentLink CommentSite -> (SrcSpan, Bool)- loc (Left (commentSpan -> srcSpan)) = (srcSpan, True )- loc (Right (siteSlice -> srcSpan)) = (srcSpan, False)- elts = (Left <$> comments) ++ (Right <$> sites)--{--type Assignment = (CommentSite, [CommentLink])--- | Assign comments to the commentable elements.-assignComments :: [Either CommentLink CommentSite]-assignComments = foldr assign ([], [], [], [])- where- assign :: ([Assignment], [Assignment], [CommentLink]- assign (assigned, unclosed, commentingAfter) nextElt = case nextElt of- Left (s@(CommentSite {})) ->- (assigned, (s,commentingAfter):unclosed, [])- Right (c@(CommentLink {commentType=CommentAfter, ..}) -> - (assigned, unclosed, c:commentingAfter)- Right (c@(CommentLink {commentType=CommentBefore, ..}) -> - (assigned, unclosed, c:commentingAfter)- Right (c@(CommentLink {commentType=CommentInside, ..}) -> - (assigned, unclosed, c:commentingAfter)- -}
− Language/Haskell/Homplexity/Cyclomatic.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Computing cyclomatic complexity and branching depth.-module Language.Haskell.Homplexity.Cyclomatic(- Cyclomatic- , cyclomaticT- , Depth- , depthT) where--import Data.Data-import Data.Generics.Uniplate.Data-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts.Syntax-import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.Metric--type MatchSet = [Match SrcLoc]---- * Cyclomatic complexity--- | Represents cyclomatic complexity-newtype Cyclomatic = Cyclomatic { unCyclo :: Int }- deriving (Eq, Ord, Enum, Num, Real, Integral)---- | For passing @Cyclomatic@ type as parameter.-cyclomaticT :: Proxy Cyclomatic -cyclomaticT = Proxy--instance Show Cyclomatic where- showsPrec _ (Cyclomatic cc) = ("cyclomatic complexity of " ++)- . shows cc--instance Metric Cyclomatic Function where- measure x = Cyclomatic . cyclomatic $ x---- | Computing cyclomatic complexity on a code fragment-cyclomatic :: Data from => from -> Int-cyclomatic x = cyclomaticOfMatches x- + cyclomaticOfExprs x- + 1---- | Sum the results of mapping the function over the list.-sumOf :: (a -> Int) -> [a] -> Int-sumOf f = sum . map f---- | Compute cyclomatic complexity of pattern matches.-cyclomaticOfMatches :: Data from => from -> Int-cyclomaticOfMatches = sumOf recurse . childrenBi- where- recurse :: MatchSet -> Int- recurse x = length x - 1 + sumOf cyclomaticOfMatches x---- | Cyclomatic complexity of all expressions-cyclomaticOfExprs :: forall from.- Data from => from -> Int-cyclomaticOfExprs = sumOf armCount . (universeBi :: from -> [Exp SrcLoc])- where- armCount (If {} ) = 2 - 1- armCount (MultiIf _ alts) = length alts - 1- armCount (LCase _ alts) = length alts - 1- armCount (Case _ _ alts) = length alts - 1- armCount _ = 0 -- others are ignored---- * Decision depth--- | Sum the results of mapping the function over the list.-maxOf :: (a -> Int) -> [a] -> Int-maxOf f = maximum . (0:). map f---- | Decision depth-newtype Depth = Depth Int- deriving (Eq, Ord, Enum, Num, Real, Integral)---- | For passing @Depth@ type as parameter.-depthT :: Proxy Depth -depthT = Proxy--instance Metric Depth Function where- measure (Function {..}) = Depth $ depthOfMatches functionRhs `max` depthOfMatches functionBinds--instance Show Depth where- showsPrec _ (Depth d) = ("branching depth of "++)- . shows d---- | Depth of branching within @Exp@ression.-depthOfExpr :: Exp SrcLoc -> Int-depthOfExpr x = fromEnum (isDecision x)+maxOf depthOfExpr (children x)---- | Helper function to compute depth of branching within @case@ expression match.-depthOfMatches :: Data from => [from] -> Int-depthOfMatches [] = 0 -- Should never happen-depthOfMatches [m ] = maxOf depthOfExpr (childrenBi m )-depthOfMatches ms = 1+maxOf depthOfExpr (concatMap childrenBi ms)---- | Check whether given @Exp@ression node is a decision node (conditional branch.)-isDecision :: Exp SrcLoc -> Bool-isDecision (If {}) = True-isDecision (MultiIf {}) = True -isDecision (LCase {}) = True-isDecision (Case {}) = True-isDecision _ = False-
− Language/Haskell/Homplexity/Message.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--- | Classifying messages by severity and filtering them.-module Language.Haskell.Homplexity.Message (- Log- , Message- , Severity (..)- , severityOptions- , critical- , warn- , info- , debug- , message- , extract- ) where--import Control.Arrow-import Control.DeepSeq-import Data.Function (on)-import Data.Foldable as Foldable-import Data.Monoid-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup-#endif-import Data.Sequence as Seq-import Language.Haskell.Exts-import Language.Haskell.TH.Syntax (Lift(..))-import HFlags---- | Keeps a set of messages-newtype Log = Log { unLog :: Seq Message }- deriving(Monoid-#if MIN_VERSION_base(4,9,0)- ,Semigroup-#endif- )--instance NFData Log where- rnf = rnf . unLog---- | Message from analysis-data Message = Message { msgSeverity :: !Severity- , msgText :: !String- , msgSrc :: !SrcLoc- }- deriving (Eq)--instance NFData Message where- rnf Message {..} = rnf msgSeverity `seq` rnf msgText `seq` rnf msgSrc--instance NFData SrcLoc where- rnf SrcLoc {..} = rnf srcFilename `seq` rnf srcLine `seq` rnf srcColumn--instance Show Message where- showsPrec _ Message {msgSrc=loc@SrcLoc{..}, ..} = shows msgSeverity- . (':':)- . (srcFilename++)- . (':':)- . shows loc- -- . shows srcLine- -- . shows srcColumn- . (':':)- . (msgText++)- . ('\n':)---- | Message severity-data Severity = Debug- | Info- | Warning- | Critical- deriving (Eq, Ord, Read, Show, Enum, Bounded)--instance NFData Severity where- rnf !_a = ()---- | String showing all possible values for @Severity@.-severityOptions :: String-severityOptions = unwords $ map show [minBound..(maxBound::Severity)]--instance Lift Severity where- lift Debug = [| Debug |]- lift Info = [| Info |]- lift Warning = [| Warning |]- lift Critical = [| Critical |]--instance FlagType Severity where- defineFlag n v = defineEQFlag n [| v :: Severity |] "{Debug|Info|Warning|Critical}"---- | Helper for logging a message with given severity.-message :: Severity -> SrcLoc -> String -> Log-message msgSeverity msgSrc msgText = Log $ Seq.singleton Message {..}---- | TODO: automatic inference of the srcLine --- | Log a certain error-critical :: SrcLoc -> String -> Log-critical = message Critical---- | Log a warning-warn :: SrcLoc -> String -> Log-warn = message Warning---- | Log informational message-info :: SrcLoc -> String -> Log-info = message Info---- | Log debugging message-debug :: SrcLoc -> String -> Log-debug = message Debug---- TODO: check if this is not too slow-msgOrdering :: Message -> Message -> Ordering-msgOrdering = compare `on` ((srcFilename &&& srcLine) . msgSrc)---- | Convert @Log@ into ordered sequence (@Seq@).-orderedMessages :: Severity -> Log -> Seq Message-orderedMessages severity Log {..} = Seq.unstableSortBy msgOrdering $- Seq.filter ((severity<=) . msgSeverity) unLog---- | Extract an ordered sequence of messages from the @Log@.-extract :: Severity -> Log -> [Message]-extract severity = Foldable.toList- . orderedMessages severity--instance Show Log where- showsPrec _ l e = Foldable.foldr shows e $- orderedMessages Debug l-
− Language/Haskell/Homplexity/Metric.hs
@@ -1,58 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Class for defining code metrics, and its simplest implementation - number of lines of code. -module Language.Haskell.Homplexity.Metric (- Metric (..)- , LOC- , locT- , measureAs- , measureFor- ) where--import Data.Data-import Data.Function-import Data.Functor-import Data.Generics.Uniplate.Data-import Data.List-import Control.Arrow-import Language.Haskell.Exts.SrcLoc---import Language.Haskell.Exts.Syntax--import Language.Haskell.Homplexity.CodeFragment---- | Metric can be computed on a set of @CodeFragment@ fragments--- and then shown.-class (CodeFragment c, Show m) => Metric m c where- measure :: c -> m---- | Number of lines of code--- (example metric)-newtype LOC = LOC { asInt :: Int }- deriving (Ord, Eq, Enum, Num, Real, Integral)---- | Proxy for passing @LOC@ type as parameter.-locT :: Proxy LOC-locT = Proxy--instance Show LOC where- showsPrec _ (LOC l) = shows l . (" lines of code"++)--instance Read LOC where- readsPrec prec str = first LOC <$> readsPrec prec str--instance (CodeFragment c) => Metric LOC c where- measure = LOC- . length -- total number of lines that contain at least one object with SrcLoc- . concatMap (nub . map srcLine) -- remove duplicate lines within the same file- . groupBy ((==) `on` srcFilename) -- group by filename- . universeBi -- all SrcLoc objects---- | Convenience function for fixing the @Metric@ type.-measureAs :: (Metric m c) => Proxy m -> c -> m-measureAs _ = measure---- | Convenience function for fixing both the @Metric@ and @CodeFragment@ for which the metric is computed.-measureFor :: (Metric m c) => Proxy m -> Proxy c -> c -> m-measureFor _ _ = measure
− Language/Haskell/Homplexity/Parse.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}--- | Parsing of Haskell source files, and error reporting for unparsable files.-module Language.Haskell.Homplexity.Parse (parseSource) where--import Control.Exception as E-import Data.Functor--import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts-import Language.Haskell.Homplexity.Comments-import Language.Haskell.Homplexity.Message-import Language.Preprocessor.Cpphs----import HFlags---- | Maximally permissive list of language extensions.-myExtensions :: [Extension]-myExtensions = EnableExtension `map`- [RecordWildCards,- ScopedTypeVariables, CPP, MultiParamTypeClasses, TemplateHaskell, RankNTypes, UndecidableInstances,- FlexibleContexts, KindSignatures, EmptyDataDecls, BangPatterns, ForeignFunctionInterface,- Generics, MagicHash, ViewPatterns, PatternGuards, TypeOperators, GADTs, PackageImports,- MultiWayIf, SafeImports, ConstraintKinds, TypeFamilies, IncoherentInstances, FunctionalDependencies,- ExistentialQuantification, ImplicitParams, UnicodeSyntax,- LambdaCase, TupleSections, NamedFieldPuns]---- | CppHs options that should be compatible with haskell-src-exts-cppHsOptions :: CpphsOptions-cppHsOptions = defaultCpphsOptions {- boolopts = defaultBoolOptions {- macros = False,- stripEol = True,- stripC89 = True,- pragma = False,- hashline = False,- locations = True -- or False if doesn't compile...- }- }---- | Parse Haskell source file, using CppHs for preprocessing,--- and haskell-src-exts for parsing.------ Catches all exceptions and wraps them as @Critical@ log messages.-parseSource :: FilePath -> IO (Either Log (Module SrcLoc, [CommentLink]))-parseSource inputFilename = do- parseResult <- (do- input <- readFile inputFilename- result <- parseModuleWithComments parseMode <$> runCpphs cppHsOptions inputFilename input- evaluate result)- `E.catch` handleException (ParseFailed thisFileLoc)- case parseResult of- ParseOk (parsed, comments) -> do {-putStrLn "ORDERED:"- putStrLn $ unlines $ map show- $ orderCommentsAndCommentables (commentable parsed )- (classifyComments comments) -}- return $ Right (getPointLoc <$> parsed,- classifyComments comments) - ParseFailed aLoc msg -> return $ Left $ critical aLoc msg- where- handleException helper (e :: SomeException) = return $ helper $ show e- thisFileLoc = noLoc { srcFilename = inputFilename }- parseMode = ParseMode {- parseFilename = inputFilename- , baseLanguage = Haskell2010- , extensions = myExtensions- , ignoreLanguagePragmas = False- , ignoreLinePragmas = False- , fixities = Just preludeFixities- , ignoreFunctionArity = False- }-{-putStrLn "COMMENTS:"- putStrLn $ unlines $ map show $ classifyComments comments- putStrLn "COMMENTABLES:"- putStrLn $ unlines $ map show $ commentable parsed-}-
− Language/Haskell/Homplexity/SrcSlice.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}--- | Showing references to slices of code-module Language.Haskell.Homplexity.SrcSlice (- SrcSlice- , srcSlice- , srcLoc- , showSrcSpan- , mergeSrcLocs- , sliceFirstLine- , sliceLastLine- , sliceFilename- , locAsSpan- ) where--import Data.Data-import Data.Generics.Uniplate.Data-import Control.Arrow-import Control.Exception (assert)-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc---- * Slice of code-type SrcSlice = SrcSpan--sliceFilename :: SrcSpan -> String-sliceFilename = srcSpanFilename--sliceFirstLine :: SrcSpan -> Int-sliceFirstLine = srcSpanStartLine--sliceLastLine :: SrcSpan -> Int-sliceLastLine = srcSpanEndLine--srcLoc :: (Data code, Show code) => code -> SrcLoc-srcLoc code = checkHead $- universeBi code- where- msg = "Cannot find SrcLoc in the code fragment: " ++ show code- checkHead [] = error msg- checkHead (e:_) = e---- | Compute the slice of code that given source fragment is in (for naming)-srcSlice :: (Data a, Show a)- => a -> SrcSpan-srcSlice code = mergeSrcLocs- . checkNonEmpty- . universeBi $ code- where- checkNonEmpty [] = error $ "Can't know how make a SrcSlice from code fragment: " ++ show code- checkNonEmpty other = other--mergeSrcLocs :: [SrcLoc] -> SrcSpan-mergeSrcLocs [] = error "Don't know how make a SrcSpan from an empty list of locations!"-mergeSrcLocs sliceLocs = allEqual (map srcFilename sliceLocs) `assert`- SrcSpan {..}- where- srcSpanFilename = srcFilename $ head sliceLocs- ((srcSpanStartLine, srcSpanStartColumn),- (srcSpanEndLine, srcSpanEndColumn )) = (minimum &&& maximum) $- map (srcLine &&& srcColumn) sliceLocs--locAsSpan :: SrcLoc -> SrcSpan-locAsSpan (SrcLoc {..}) = SrcSpan { srcSpanStartLine = srcLine- , srcSpanEndLine = srcLine- , srcSpanStartColumn = srcColumn- , srcSpanEndColumn = srcColumn- , srcSpanFilename = srcFilename- }--allEqual :: Eq a => [a] -> Bool-allEqual [] = True-allEqual (b:bs) = all (b==) bs--showSrcSpan :: SrcSpan -> ShowS-showSrcSpan (SrcSpan {..}) = shows srcSpanFilename- . (':':)- . shows srcSpanStartLine- . ('-':)- . shows srcSpanEndLine-
− Language/Haskell/Homplexity/TypeComplexity.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Computing cyclomatic complexity and branching depth.-module Language.Haskell.Homplexity.TypeComplexity(- ConDepth- , conDepthT- , NumFunArgs- , numFunArgsT) where--import Data.Data-import Data.Generics.Uniplate.Data---import Data.Proxy(Proxy)-import Language.Haskell.Exts.Syntax-import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.Metric---import Debug.Trace---- | Sum the results of mapping the function over the list.-maxOf :: (a -> Int) -> [a] -> Int-maxOf f = maximum . (0:). map f---- * Depth of type constructor nesting-newtype ConDepth = ConDepth { unConDepth :: Int }- deriving (Eq, Ord, Enum, Num, Real, Integral)--conDepthT :: Proxy ConDepth-conDepthT = Proxy--instance Show ConDepth where- showsPrec _ (ConDepth cc) = ("type constructor nesting of " ++)- . shows cc--instance Metric ConDepth TypeSignature where- measure = ConDepth . conDepth . theType---- | Function computing constructor depth of a @Type@.-conDepth :: (Eq a, Data a) => Type a -> Int-conDepth con = deeper con + maxOf conDepth (filter (/= con) $ childrenBi con)---- | Check whether given constructor of @Type@ counts in constructor depth computation.-deeper :: Type a -> Int-deeper (TyForall _ _bind _context _type) = 1-deeper (TyList _ _aType ) = 1-deeper (TyFun _ _type1 _type2) = 1-deeper (TyApp _ _type1 _type2) = 1-deeper (TyInfix _ _type1 _ _type2) = 1-deeper (TyTuple _ _boxed _types) = 1-deeper (TyParArray _ _types) = 1-deeper _ = 0---- * Number of function arguments-newtype NumFunArgs = NumFunArgs { _unNumFunArgs :: Int }- deriving (Eq, Ord, Enum, Num, Real, Integral)--numFunArgsT :: Proxy NumFunArgs-numFunArgsT = Proxy--instance Show NumFunArgs where- showsPrec _ (NumFunArgs cc) = shows cc- . (" arguments" ++)--instance Metric NumFunArgs TypeSignature where- measure = NumFunArgs . numFunArgs . theType---- | Function computing constructor depth of a @Type@.-numFunArgs :: Type a -> Int-numFunArgs (TyParen _ aType) = numFunArgs aType-numFunArgs (TyKind _ aType _kind) = numFunArgs aType-numFunArgs (TyForall _ _bind _context aType) = numFunArgs aType -- NOTE: doesn't count type argument-numFunArgs (TyFun _ _type1 type2) = 1+numFunArgs type2-numFunArgs (TyParArray _ aType) = 1+numFunArgs aType-numFunArgs _ = 1-
README.md view
@@ -6,7 +6,10 @@ For parsing it uses [haskell-src-exts](http://hackage.haskell.org/package/haskell-src-exts), and [cppHs](http://hackage.haskell.org/package/cppHs). -[](https://travis-ci.org/mgajda/homplexity)+Builds across GHC versions: [](https://travis-ci.org/mgajda/homplexity)++Builds with Stack: [](https://circleci.com/gh/mgajda/homplexity)+ [](https://hackage.haskell.org/package/homplexity) [](http://packdeps.haskellers.com/feed?needle=homplexity)
+ app/Homplexity.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- | Main module parsing inputs, and running analysis.+module Main (main) where++import Data.Functor+import Data.List+import Data.Monoid++import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts.Syntax+import Language.Haskell.Homplexity.Assessment+import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Message+import Language.Haskell.Homplexity.Parse+import System.Directory+import System.Exit+import System.FilePath+import System.IO++import HFlags++-- * Command line flag+defineFlag "severity" Warning (concat ["level of output verbosity (", severityOptions, ")"])++-- | Report to standard error output.+report :: String -> IO ()+report = hPutStrLn stderr++-- * Recursing directory tree in order to list Haskell source files.+-- | Find all Haskell source files within a given path.+-- Recurse down the tree, if the path points to directory.+subTrees :: FilePath -> IO [FilePath]+-- Recurse to . or .. only at the first level, to prevent looping:+subTrees dir | dir `elem` [".", ".."] = concatMapM subTrees' =<< getDirectoryPaths dir+subTrees filepath = do+ isDir <- doesDirectoryExist filepath+ if isDir+ then subTrees' filepath+ else do+ exists <- doesFileExist filepath+ if exists+ then return [filepath]+ else do report $ "File does not exist: " ++ filepath+ return []++-- | Return filepath if normal file, or recurse down the directory if it is not special directory ("." or "..")+subTrees' :: FilePath -> IO [FilePath]+subTrees' (takeFileName -> "..") = return []+subTrees' (takeFileName -> "." ) = return []+subTrees' fp = do+ isDir <- doesDirectoryExist fp+ if isDir+ then concatMapM subTrees' =<< getDirectoryPaths fp+ else return $ filter (".hs" `isSuffixOf`) [fp]++-- | Get contents of a given directory, and return their full paths.+getDirectoryPaths :: FilePath -> IO [FilePath]+getDirectoryPaths dirPath = map (dirPath </>) <$> getDirectoryContents dirPath++-- | Commonly defined function - should be added to base...+concatMapM :: (Functor m, Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f++-- * Analysis+-- | Analyze a set of modules.+analyzeModule :: Module SrcLoc -> IO ()+analyzeModule = putStr+ . concatMap show+ . extract flags_severity+ . mconcat metrics+ . program+ . (:[])++-- | Process each separate input file.+processFile :: FilePath -> IO Bool+processFile filepath = do src <- parseSource filepath+ case src of+ Left msg -> do report $ show msg+ return False+ Right (ast, _comments) -> do analyzeModule ast+ return True++-- | This flag exists only to make sure that HFLags work.+defineFlag "fakeFlag" Info "this flag is fake"++-- | Parse arguments and either process inputs (if available), or suggest proper usage.+main :: IO ()+main = do+ args <- $initHFlags "Homplexity - automatic analysis of Haskell code quality"+ if null args+ then do report ("Use Haskell source file or directory as an argument, " +++ "or use --help to discover options.")+ exitFailure+ else do sums <- mapM processFile =<< concatMapM subTrees args+ putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums,+ "out of", show $ length sums,+ "input files."]+
changelog.md view
@@ -1,5 +1,9 @@ Changelog =========+ 0.4.4.2 Nov 2018+ * Releases on GitHub release page+ * Automated Docker build+ 0.4.4.1 Nov 2018 * Fix crashes on unnamed modules, and XML pages
homplexity.cabal view
@@ -1,5 +1,5 @@ name: homplexity-version: 0.4.4.1+version: 0.4.4.2 synopsis: Haskell code quality tool description: Homplexity aims to measure code complexity, warning about fragments that might have higher defect probability@@ -44,23 +44,20 @@ Language.Haskell.Homplexity.Parse Language.Haskell.Homplexity.TypeComplexity Language.Haskell.Homplexity.SrcSlice- Hs-source-dirs: .+ Hs-source-dirs: lib+ build-tools: happy >= 1.19.0 Other-Modules: Paths_homplexity- build-depends: base- ,haskell-src-exts- ,directory- ,filepath- ,hflags- ,uniplate- ,deepseq- ,containers- ,template-haskell- ,cpphs- default-language: Haskell2010--executable homplexity- main-is: Homplexity.hs+ build-depends: base >=4.5 && <4.13,+ haskell-src-exts >=1.18 && <1.21,+ directory >=1.1 && <1.4,+ filepath >=1.2 && <1.5,+ hflags >=0.3 && <0.5,+ uniplate >=1.4 && <1.7,+ deepseq >=1.3 && <1.7,+ containers >=0.3 && <0.7,+ template-haskell >=2.6 && <2.16,+ cpphs >=1.5 && <1.21 other-extensions: FlexibleContexts, FlexibleInstances, UndecidableInstances,@@ -77,6 +74,11 @@ BangPatterns, GeneralizedNewtypeDeriving, TypeFamilies+ default-language: Haskell2010++executable homplexity+ main-is: Homplexity.hs+ hs-source-dirs: app/ build-depends: base >=4.5 && <4.13, haskell-src-exts >=1.18 && <1.21, directory >=1.1 && <1.4,@@ -85,19 +87,21 @@ uniplate >=1.4 && <1.7, deepseq >=1.3 && <1.7, containers >=0.3 && <0.7,- template-haskell >=2.6 && <2.14,+ template-haskell >=2.6 && <2.16, cpphs >=1.5 && <1.21, homplexity- build-tools: happy >= 1.19.0 default-language: Haskell2010+ -- STATIC: ld-options: -static+ -- STATIC: ghc-options: -fPIC test-suite Comments- main-is: tests/Comments.hs+ main-is: Comments.hs+ hs-source-dirs: lib tests other-modules: Language.Haskell.Homplexity.CodeFragment Language.Haskell.Homplexity.Comments Language.Haskell.Homplexity.SrcSlice type: exitcode-stdio-1.0- build-depends: base >=4.5 && <4.12,+ build-depends: base >=4.5 && <4.13, haskell-src-exts >=1.18 && <1.21, uniplate >=1.4 && <1.7 default-language: Haskell2010
+ lib/Language/Haskell/Homplexity/Assessment.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+-- | Main module parsing inputs, and running analysis.+module Language.Haskell.Homplexity.Assessment (+ metrics+ --, measureAllOccurs+ ) where++import Data.Data+import Data.Monoid++import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Cyclomatic+import Language.Haskell.Homplexity.Message+import Language.Haskell.Homplexity.Metric+import Language.Haskell.Homplexity.TypeComplexity++import HFlags++{-+numFunctions = length+ . filter isFunBind+ . getModuleDecls++testNumFunctions = (>20)++numFunctionsMsg = "More than 20 functions per module"++numFunctionsSeverity = Warning+ -}++-- * Showing metric measurements+measureAll :: Metric m c => Assessment m -> (a -> [c]) -> Proxy m -> Proxy c -> a -> Log+measureAll assess generator metricType fragType = mconcat+ . map (warnOfMeasure assess metricType fragType)+ . generator++measureTopOccurs :: (Data from, Metric m c) => Assessment m -> Proxy m -> Proxy c -> from -> Log+measureTopOccurs assess = measureAll assess occurs++--measureAllOccurs :: (CodeFragment c, Metric m c) => Severity -> Proxy m -> Proxy c -> Program -> Log+-- | Measure all occurences of a given @CodeFragment@ with a given @Metric@,+-- then use @Assessment@ on them and give a list of @Log@ messages.+--+-- Arguments come in the following order:+-- 1. @Assessment@ for the value of the @Metric@.+-- 2. @Metric@ given as @Proxy@ type.+-- 3. @CodeFragment@ given as @Proxy@ type.+-- 4. Program containing @CodeFragment@s.+measureAllOccurs :: (Data from, Metric m c) => Assessment m -> Proxy m -> Proxy c -> from -> Log+measureAllOccurs assess = measureAll assess allOccurs++-- | Type of functions that convert a @Metric@ into a log message.+type Assessment m = m -> (Severity, String)++warnOfMeasure :: (CodeFragment c, Metric m c) => Assessment m -> Proxy m -> Proxy c -> c -> Log+warnOfMeasure assess metricType fragType c = message severity+ ( fragmentLoc c )+ (unwords [fragmentName c+ ,"has"+ ,show result+ ,recommendation])+ where+ (severity, recommendation) = assess result+ result = measureFor metricType fragType c++-- * Assessments of severity for used @Metric@s.+-- ** Module definition checks+defineFlag "moduleLinesWarning" (500 :: Int) "issue warning when module exceeds this number of lines"+defineFlag "moduleLinesCritical" (3000 :: Int) "issue critical when module exceeds this number of lines"++assessModuleLength :: Assessment LOC+assessModuleLength (fromIntegral -> locs)+ | locs > flags_moduleLinesWarning = (Warning, "should be kept below " +++ show flags_moduleLinesWarning +++ " lines of code.")+ | locs > flags_moduleLinesCritical = (Critical, "this function exceeds " +++ show flags_moduleLinesCritical +++ " lines of code.")+ | otherwise = (Info, "" )++-- ** Function definition checks+-- *** Number of lines of code within function body+defineFlag "functionLinesWarning" (20 :: Int) "issue warning when function exceeds this number of lines"+defineFlag "functionLinesCritical" (40 :: Int) "issue critical when function exceeds this number of lines"++assessFunctionLength :: Assessment LOC+assessFunctionLength (fromIntegral -> locs)+ | locs > flags_functionLinesWarning = (Warning, "should be kept below " +++ show flags_functionLinesWarning +++ " lines of code.")+ | locs > flags_functionLinesCritical = (Critical, "this function exceeds " +++ show flags_functionLinesCritical +++ " lines of code.")+ | otherwise = (Info, "" )+++-- *** Decision depth of function definition+defineFlag "functionDepthWarning" (4 :: Int) "issue warning when function exceeds this decision depth"+defineFlag "functionDepthCritical" (8 :: Int) "issue critical when function exceeds this decision depth"++assessFunctionDepth :: Assessment Depth+assessFunctionDepth (fromIntegral -> depth)+ | depth > flags_functionDepthWarning = (Warning, "should have no more than " +++ show depth +++ " nested conditionals" )+ | depth > flags_functionDepthWarning = (Warning, "should never exceed " +++ show depth +++ " nesting levels for conditionals")+ | otherwise = (Info, "" )++-- *** Cyclomatic complexity of function definition+defineFlag "functionCCWarning" (20::Int) "issue warning when function's cyclomatic complexity exceeds this number"+defineFlag "functionCCCritical" (50::Int) "issue critical when function's cyclomatic complexity exceeds this number"++assessFunctionCC :: Assessment Cyclomatic+assessFunctionCC (fromIntegral -> cy)+ | cy > flags_functionCCWarning = (Warning, "should be less than " +++ show flags_functionCCWarning)+ | cy > flags_functionCCCritical = (Warning, "must never be as high as " +++ show flags_functionCCCritical)+ | otherwise = (Info, "" )++-- ** Type signature complexity+-- *** Type constructor depth in each type signature+defineFlag "typeConDepthWarning" (6::Int) "issue warning when type constructor depth exceeds this number"+defineFlag "typeConDepthCritical" (9::Int) "issue critical when type constructor depth exceeds this number"++assessTypeConDepth :: Assessment ConDepth+assessTypeConDepth (fromIntegral -> cy)+ | cy > flags_typeConDepthWarning = (Warning, "should be less than " +++ show flags_typeConDepthWarning )+ | cy > flags_typeConDepthCritical = (Warning, "must never be as high as " +++ show flags_typeConDepthCritical)+ | otherwise = (Info, "" )++-- *** Number of function arguments mentioned in each type signature+defineFlag "numFunArgsWarning" (5::Int) "issue warning when number of function arguments exceeds this number"+defineFlag "numFunArgsCritical" (9::Int) "issue critical when number of function arguments exceeds this number"++assessNumFunArgs :: Assessment NumFunArgs+assessNumFunArgs (fromIntegral -> cy)+ | cy > flags_numFunArgsWarning = (Warning, "should be less than " ++ show flags_numFunArgsWarning )+ | cy > flags_numFunArgsCritical = (Warning, "must never reach " ++ show flags_numFunArgsCritical)+ | otherwise = (Info, "" )++-- * Computing and assessing @Metric@s for all @CodeFragment@.+-- | Compute all metrics, and assign severity depending on configured thresholds.+metrics :: [Program -> Log]+metrics = [measureTopOccurs assessModuleLength locT moduleT+ ,measureTopOccurs assessFunctionLength locT functionT+ ,measureTopOccurs assessFunctionDepth depthT functionT+ ,measureTopOccurs assessFunctionCC cyclomaticT functionT+ ,measureTopOccurs assessTypeConDepth conDepthT typeSignatureT+ ,measureTopOccurs assessNumFunArgs numFunArgsT typeSignatureT]+
+ lib/Language/Haskell/Homplexity/CodeFragment.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-}+-- | This module generalizes over types of code fragments+-- that may need to be iterated upon and measured separately.+module Language.Haskell.Homplexity.CodeFragment (+ CodeFragment (fragmentName, fragmentSlice)+ , occurs+ , occursOf+ , allOccurs+ , allOccursOf+ , Program (..)+ , programT+ , program+ , Module (..)+ , moduleT+ , Function (..)+ , functionT+ , TypeSignature (..)+ , typeSignatureT+ , fragmentLoc+ -- TODO: add ClassSignature+ ) where++import Data.Data+import Data.Functor+import Data.Generics.Uniplate.Data+import Data.List+import Data.Maybe+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Homplexity.SrcSlice++-- | Program+newtype Program = Program { allModules :: [Module SrcLoc] }+ deriving (Data, Typeable, Show)++-- | Smart constructor for adding cross-references in the future.+program :: [Module SrcLoc] -> Program+program = Program++-- | Proxy for passing @Program@ type as an argument.+programT :: Proxy Program+programT = Proxy++-- * Type aliases for type-based matching of substructures+-- | Alias for a function declaration+data Function = Function {+ functionNames :: [String]+ , functionLocations :: [SrcLoc]+ , functionRhs :: [Rhs SrcLoc]+ , functionBinds :: [Binds SrcLoc]+ }+ deriving (Data, Typeable, Show)++-- | Proxy for passing @Function@ type as an argument.+functionT :: Proxy Function+functionT = Proxy++-- ** Type signature of a function+-- | Type alias for a type signature of a function as a @CodeFragment@+data TypeSignature = TypeSignature { loc :: SrcLoc+ , identifiers :: [Name SrcLoc]+ , theType :: Type SrcLoc }+ deriving (Data, Typeable, Show)++-- | Proxy for passing @Program@ type as an argument.+typeSignatureT :: Proxy TypeSignature+typeSignatureT = Proxy++-- ** TODO: class signatures (number of function decls inside)+-- | Alias for a class signature+data ClassSignature = ClassSignature+ deriving (Data, Typeable)++-- TODO: need combination of Fold and Biplate+-- Resulting record may be created to make pa++-- | Class @CodeFragment@ allows for:+-- * both selecting direct or all descendants+-- of the given type of object within another structure+-- (with @occurs@ and @allOccurs@)+-- * naming the object to allow user to distinguish it.+--+-- In order to compute selection, we just need to know which+-- @AST@ nodes contain the given object, and how to extract+-- this given object from @AST@, if it is there (@matchAST@).:w+class (Show c, Data (AST c), Data c) => CodeFragment c where+ type AST c+ matchAST :: AST c -> Maybe c+ fragmentName :: c -> String+ fragmentSlice :: c -> SrcSlice+ fragmentSlice = srcSlice++-- | First location for each @CodeFragment@ - for convenient reporting.+fragmentLoc :: (CodeFragment c) => c -> SrcLoc+fragmentLoc = getPointLoc+ . fragmentSlice++mergeBinds = catMaybes++instance CodeFragment Function where+ type AST Function = Decl SrcLoc+ matchAST (FunBind _ matches) = Just+ Function {..}+ where+ (functionLocations,+ (unName <$>) . take 1 -> functionNames,+ functionRhs,+ catMaybes -> functionBinds) = unzip4 $ map extract matches+ extract (Match srcLoc name _ rhs binds) = (srcLoc, name, rhs, binds)+ matchAST (PatBind (singleton -> functionLocations) pat+ (singleton -> functionRhs )+ (maybeToList -> functionBinds )) = Just Function {..}+ where+ functionNames = wildcards ++ map unName (universeBi pat :: [Name SrcLoc])+ wildcards = mapMaybe wildcard (universe pat)+ where+ wildcard PWildCard {} = Just ".."+ wildcard _ = Nothing+ matchAST _ = Nothing+ fragmentName Function {..} = unwords $ "function":functionNames++-- | Make a single element list.+singleton :: a -> [a]+singleton = (:[])++-- | Direct occurences of given @CodeFragment@ fragment within another structure.+occurs :: (CodeFragment c, Data from) => from -> [c]+occurs = mapMaybe matchAST . childrenBi++-- | Explicitly typed variant of @occurs@.+occursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]+occursOf _ = occurs++allOccurs :: (CodeFragment c, Data from) => from -> [c]+allOccurs = mapMaybe matchAST . universeBi++-- | Explicitly typed variant of @allOccurs@.+allOccursOf :: (Data from, CodeFragment c) => Proxy c -> from -> [c]+allOccursOf _ = allOccurs++instance CodeFragment Program where+ type AST Program = Program+ matchAST = Just+ fragmentName _ = "program"++instance CodeFragment (Module SrcLoc) where+ type AST (Module SrcLoc)= Module SrcLoc+ matchAST = Just + fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) = + "module " ++ theName+ fragmentName (Module _ Nothing _ _ _) = + "<unnamed module>"+ fragmentName (XmlPage _ (ModuleName _ theName) _ _ _ _ _) = "XML page " ++ theName+ fragmentName (XmlHybrid _ (Just (ModuleHead _ (ModuleName _ theName) _ _))+ _ _ _ _ _ _ _) = "module with XML " ++ theName+ fragmentName (XmlHybrid _ Nothing _ _ _ _ _ _ _ ) = "<unnamed module with XML>"++-- | Proxy for passing @Module@ type as an argument.+moduleT :: Proxy (Module SrcLoc)+moduleT = Proxy++instance CodeFragment TypeSignature where+ type AST TypeSignature = Decl SrcLoc+ matchAST (TypeSig loc identifiers theType) = Just TypeSignature {..}+ matchAST _ = Nothing+ fragmentName TypeSignature {..} = "type signature for "+ ++ intercalate ", " (map unName identifiers)++-- | Unpack @Name@ identifier into a @String@.+unName :: Name a -> String+unName (Symbol _ s) = s+unName (Ident _ i) = i +
+ lib/Language/Haskell/Homplexity/Comments.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+module Language.Haskell.Homplexity.Comments (+ CommentLink (..)+ , CommentType (..)+ , classifyComments+ , findCommentType -- exposed for testing only+ , CommentSite (..)+ , commentable++ , orderCommentsAndCommentables+ ) where++import Data.Char+import Data.Data+import Data.Function+import Data.Functor+import Data.List++import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.SrcSlice+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts++-- | Describes the comment span, and the way it may be connected to the+-- source code+data CommentLink = CommentLink { commentSpan :: SrcSpan+ , commentType :: CommentType+ }+ deriving(Eq, Ord, Show)++-- | Possible link between comment and commented entity.+data CommentType = CommentsBefore -- ^ May be counted as commenting object that starts just before.+ | CommentsInside -- ^ May be counted as commenting object within which it exists.+ | CommentsAfter -- ^ May be counted as commenting object that starts just after.+ deriving (Eq, Ord, Enum, Show)++-- | Classifies all comments in list, so they can be assigned to declarations later.+classifyComments :: [Comment] -> [CommentLink]+classifyComments = map classifyComment+ where+ classifyComment (Comment _ commentSpan (findCommentType -> commentType)) = CommentLink {..}++-- | Finds Haddock markers of which declarations the comment pertains to.+findCommentType :: String -> CommentType+findCommentType txt = case (not . isSpace) `find` txt of+ Just '^' -> CommentsBefore+ Just '|' -> CommentsAfter+ Just '*' -> CommentsInside -- since it comments out the group of declarations, it belongs to the containing object+ _ -> CommentsInside++-- * Finding ranges of all commentable entities.+-- | Tagging of source range for each commentable object.+data CommentSite = CommentSite { siteName :: String+ , siteSlice :: SrcSlice+ }+ deriving (Show)++-- | Find comment sites for entire program.+commentable :: Data from => from -> [CommentSite]+commentable code = ($ code) `concatMap` [slicesOf functionT+ ,slicesOf typeSignatureT+ ,slicesOf moduleT ]+ where+ commentSite :: CodeFragment c => (c -> SrcSlice) -> c -> CommentSite+ commentSite with frag = CommentSite (fragmentName frag)+ (with frag)+ commentSites :: (CodeFragment c, Data from) => (c -> SrcSlice) -> Proxy c -> from -> [CommentSite]+ commentSites with fragType = map (commentSite with) . occursOf fragType+ slicesOf :: (CodeFragment c, Data from) => Proxy c -> from -> [CommentSite]+ slicesOf = commentSites fragmentSlice + --locsOf = commentSites (locAsSpan . fragmentLoc)++-- | Take together are commentable elements, and all comments, and order them by source location.+orderCommentsAndCommentables :: [CommentSite] -> [CommentLink] -> [Either CommentLink CommentSite]+orderCommentsAndCommentables sites comments = sortBy (compare `on` loc) elts+ where+ loc :: Either CommentLink CommentSite -> (SrcSpan, Bool)+ loc (Left (commentSpan -> srcSpan)) = (srcSpan, True )+ loc (Right (siteSlice -> srcSpan)) = (srcSpan, False)+ elts = (Left <$> comments) ++ (Right <$> sites)++{-+type Assignment = (CommentSite, [CommentLink])+-- | Assign comments to the commentable elements.+assignComments :: [Either CommentLink CommentSite]+assignComments = foldr assign ([], [], [], [])+ where+ assign :: ([Assignment], [Assignment], [CommentLink]+ assign (assigned, unclosed, commentingAfter) nextElt = case nextElt of+ Left (s@(CommentSite {})) ->+ (assigned, (s,commentingAfter):unclosed, [])+ Right (c@(CommentLink {commentType=CommentAfter, ..}) -> + (assigned, unclosed, c:commentingAfter)+ Right (c@(CommentLink {commentType=CommentBefore, ..}) -> + (assigned, unclosed, c:commentingAfter)+ Right (c@(CommentLink {commentType=CommentInside, ..}) -> + (assigned, unclosed, c:commentingAfter)+ -}
+ lib/Language/Haskell/Homplexity/Cyclomatic.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Computing cyclomatic complexity and branching depth.+module Language.Haskell.Homplexity.Cyclomatic(+ Cyclomatic+ , cyclomaticT+ , Depth+ , depthT) where++import Data.Data+import Data.Generics.Uniplate.Data+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts.Syntax+import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Metric++type MatchSet = [Match SrcLoc]++-- * Cyclomatic complexity+-- | Represents cyclomatic complexity+newtype Cyclomatic = Cyclomatic { unCyclo :: Int }+ deriving (Eq, Ord, Enum, Num, Real, Integral)++-- | For passing @Cyclomatic@ type as parameter.+cyclomaticT :: Proxy Cyclomatic +cyclomaticT = Proxy++instance Show Cyclomatic where+ showsPrec _ (Cyclomatic cc) = ("cyclomatic complexity of " ++)+ . shows cc++instance Metric Cyclomatic Function where+ measure x = Cyclomatic . cyclomatic $ x++-- | Computing cyclomatic complexity on a code fragment+cyclomatic :: Data from => from -> Int+cyclomatic x = cyclomaticOfMatches x+ + cyclomaticOfExprs x+ + 1++-- | Sum the results of mapping the function over the list.+sumOf :: (a -> Int) -> [a] -> Int+sumOf f = sum . map f++-- | Compute cyclomatic complexity of pattern matches.+cyclomaticOfMatches :: Data from => from -> Int+cyclomaticOfMatches = sumOf recurse . childrenBi+ where+ recurse :: MatchSet -> Int+ recurse x = length x - 1 + sumOf cyclomaticOfMatches x++-- | Cyclomatic complexity of all expressions+cyclomaticOfExprs :: forall from.+ Data from => from -> Int+cyclomaticOfExprs = sumOf armCount . (universeBi :: from -> [Exp SrcLoc])+ where+ armCount (If {} ) = 2 - 1+ armCount (MultiIf _ alts) = length alts - 1+ armCount (LCase _ alts) = length alts - 1+ armCount (Case _ _ alts) = length alts - 1+ armCount _ = 0 -- others are ignored++-- * Decision depth+-- | Sum the results of mapping the function over the list.+maxOf :: (a -> Int) -> [a] -> Int+maxOf f = maximum . (0:). map f++-- | Decision depth+newtype Depth = Depth Int+ deriving (Eq, Ord, Enum, Num, Real, Integral)++-- | For passing @Depth@ type as parameter.+depthT :: Proxy Depth +depthT = Proxy++instance Metric Depth Function where+ measure (Function {..}) = Depth $ depthOfMatches functionRhs `max` depthOfMatches functionBinds++instance Show Depth where+ showsPrec _ (Depth d) = ("branching depth of "++)+ . shows d++-- | Depth of branching within @Exp@ression.+depthOfExpr :: Exp SrcLoc -> Int+depthOfExpr x = fromEnum (isDecision x)+maxOf depthOfExpr (children x)++-- | Helper function to compute depth of branching within @case@ expression match.+depthOfMatches :: Data from => [from] -> Int+depthOfMatches [] = 0 -- Should never happen+depthOfMatches [m ] = maxOf depthOfExpr (childrenBi m )+depthOfMatches ms = 1+maxOf depthOfExpr (concatMap childrenBi ms)++-- | Check whether given @Exp@ression node is a decision node (conditional branch.)+isDecision :: Exp SrcLoc -> Bool+isDecision If {} = True+isDecision MultiIf {} = True +isDecision LCase {} = True+isDecision Case {} = True+isDecision _ = False+
+ lib/Language/Haskell/Homplexity/Message.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Classifying messages by severity and filtering them.+module Language.Haskell.Homplexity.Message (+ Log+ , Message+ , Severity (..)+ , severityOptions+ , critical+ , warn+ , info+ , debug+ , message+ , extract+ ) where++import Control.Arrow+import Control.DeepSeq+import Data.Function (on)+import Data.Foldable as Foldable+import Data.Monoid+#if __GLASGOW_HASKELL__ >= 800+-- MIN_VERSION_base(4,9,0)+import Data.Semigroup+#endif+import Data.Sequence as Seq+import Language.Haskell.Exts+import Language.Haskell.TH.Syntax (Lift(..))+import HFlags++-- | Keeps a set of messages+newtype Log = Log { unLog :: Seq Message }+ deriving(Monoid+#if __GLASGOW_HASKELL__ >= 800+-- #if MIN_VERSION_base(4,9,0)+ ,Semigroup+#endif+ )++instance NFData Log where+ rnf = rnf . unLog++-- | Message from analysis+data Message = Message { msgSeverity :: !Severity+ , msgText :: !String+ , msgSrc :: !SrcLoc+ }+ deriving (Eq)++instance NFData Message where+ rnf Message {..} = rnf msgSeverity `seq` rnf msgText `seq` rnf msgSrc++instance NFData SrcLoc where+ rnf SrcLoc {..} = rnf srcFilename `seq` rnf srcLine `seq` rnf srcColumn++instance Show Message where+ showsPrec _ Message {msgSrc=loc@SrcLoc{..}, ..} = shows msgSeverity+ . (':':)+ . (srcFilename++)+ . (':':)+ . shows loc+ -- . shows srcLine+ -- . shows srcColumn+ . (':':)+ . (msgText++)+ . ('\n':)++-- | Message severity+data Severity = Debug+ | Info+ | Warning+ | Critical+ deriving (Eq, Ord, Read, Show, Enum, Bounded)++instance NFData Severity where+ rnf !_a = ()++-- | String showing all possible values for @Severity@.+severityOptions :: String+severityOptions = unwords $ map show [minBound..(maxBound::Severity)]++instance Lift Severity where+ lift Debug = [| Debug |]+ lift Info = [| Info |]+ lift Warning = [| Warning |]+ lift Critical = [| Critical |]++instance FlagType Severity where+ defineFlag n v = defineEQFlag n [| v :: Severity |] "{Debug|Info|Warning|Critical}"++-- | Helper for logging a message with given severity.+message :: Severity -> SrcLoc -> String -> Log+message msgSeverity msgSrc msgText = Log $ Seq.singleton Message {..}++-- | TODO: automatic inference of the srcLine +-- | Log a certain error+critical :: SrcLoc -> String -> Log+critical = message Critical++-- | Log a warning+warn :: SrcLoc -> String -> Log+warn = message Warning++-- | Log informational message+info :: SrcLoc -> String -> Log+info = message Info++-- | Log debugging message+debug :: SrcLoc -> String -> Log+debug = message Debug++-- TODO: check if this is not too slow+msgOrdering :: Message -> Message -> Ordering+msgOrdering = compare `on` ((srcFilename &&& srcLine) . msgSrc)++-- | Convert @Log@ into ordered sequence (@Seq@).+orderedMessages :: Severity -> Log -> Seq Message+orderedMessages severity Log {..} = Seq.unstableSortBy msgOrdering $+ Seq.filter ((severity<=) . msgSeverity) unLog++-- | Extract an ordered sequence of messages from the @Log@.+extract :: Severity -> Log -> [Message]+extract severity = Foldable.toList+ . orderedMessages severity++instance Show Log where+ showsPrec _ l e = Foldable.foldr shows e $+ orderedMessages Debug l+
+ lib/Language/Haskell/Homplexity/Metric.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Class for defining code metrics, and its simplest implementation - number of lines of code. +module Language.Haskell.Homplexity.Metric (+ Metric (..)+ , LOC+ , locT+ , measureAs+ , measureFor+ ) where++import Data.Data+import Data.Function+import Data.Functor+import Data.Generics.Uniplate.Data+import Data.List+import Control.Arrow+import Language.Haskell.Exts.SrcLoc+--import Language.Haskell.Exts.Syntax++import Language.Haskell.Homplexity.CodeFragment++-- | Metric can be computed on a set of @CodeFragment@ fragments+-- and then shown.+class (CodeFragment c, Show m) => Metric m c where+ measure :: c -> m++-- | Number of lines of code+-- (example metric)+newtype LOC = LOC { asInt :: Int }+ deriving (Ord, Eq, Enum, Num, Real, Integral)++-- | Proxy for passing @LOC@ type as parameter.+locT :: Proxy LOC+locT = Proxy++instance Show LOC where+ showsPrec _ (LOC l) = shows l . (" lines of code"++)++instance Read LOC where+ readsPrec prec str = first LOC <$> readsPrec prec str++instance (CodeFragment c) => Metric LOC c where+ measure = LOC+ . length -- total number of lines that contain at least one object with SrcLoc+ . concatMap (nub . map srcLine) -- remove duplicate lines within the same file+ . groupBy ((==) `on` srcFilename) -- group by filename+ . universeBi -- all SrcLoc objects++-- | Convenience function for fixing the @Metric@ type.+measureAs :: (Metric m c) => Proxy m -> c -> m+measureAs _ = measure++-- | Convenience function for fixing both the @Metric@ and @CodeFragment@ for which the metric is computed.+measureFor :: (Metric m c) => Proxy m -> Proxy c -> c -> m+measureFor _ _ = measure
+ lib/Language/Haskell/Homplexity/Parse.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Parsing of Haskell source files, and error reporting for unparsable files.+module Language.Haskell.Homplexity.Parse (parseSource) where++import Control.Exception as E+import Data.Functor++import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts+import Language.Haskell.Homplexity.Comments+import Language.Haskell.Homplexity.Message+import Language.Preprocessor.Cpphs++--import HFlags++-- | Maximally permissive list of language extensions.+myExtensions :: [Extension]+myExtensions = EnableExtension `map`+ [RecordWildCards,+ ScopedTypeVariables, CPP, MultiParamTypeClasses, TemplateHaskell, RankNTypes, UndecidableInstances,+ FlexibleContexts, KindSignatures, EmptyDataDecls, BangPatterns, ForeignFunctionInterface,+ Generics, MagicHash, ViewPatterns, PatternGuards, TypeOperators, GADTs, PackageImports,+ MultiWayIf, SafeImports, ConstraintKinds, TypeFamilies, IncoherentInstances, FunctionalDependencies,+ ExistentialQuantification, ImplicitParams, UnicodeSyntax,+ LambdaCase, TupleSections, NamedFieldPuns]++-- | CppHs options that should be compatible with haskell-src-exts+cppHsOptions :: CpphsOptions+cppHsOptions = defaultCpphsOptions {+ boolopts = defaultBoolOptions {+ macros = False,+ stripEol = True,+ stripC89 = True,+ pragma = False,+ hashline = False,+ locations = True -- or False if doesn't compile...+ }+ }++-- | Parse Haskell source file, using CppHs for preprocessing,+-- and haskell-src-exts for parsing.+--+-- Catches all exceptions and wraps them as @Critical@ log messages.+parseSource :: FilePath -> IO (Either Log (Module SrcLoc, [CommentLink]))+parseSource inputFilename = do+ parseResult <- (do+ input <- readFile inputFilename+ result <- parseModuleWithComments parseMode <$> runCpphs cppHsOptions inputFilename input+ evaluate result)+ `E.catch` handleException (ParseFailed thisFileLoc)+ case parseResult of+ ParseOk (parsed, comments) -> do {-putStrLn "ORDERED:"+ putStrLn $ unlines $ map show+ $ orderCommentsAndCommentables (commentable parsed )+ (classifyComments comments) -}+ return $ Right (getPointLoc <$> parsed,+ classifyComments comments) + ParseFailed aLoc msg -> return $ Left $ critical aLoc msg+ where+ handleException helper (e :: SomeException) = return $ helper $ show e+ thisFileLoc = noLoc { srcFilename = inputFilename }+ parseMode = ParseMode {+ parseFilename = inputFilename+ , baseLanguage = Haskell2010+ , extensions = myExtensions+ , ignoreLanguagePragmas = False+ , ignoreLinePragmas = False+ , fixities = Just preludeFixities+ , ignoreFunctionArity = False+ }+{-putStrLn "COMMENTS:"+ putStrLn $ unlines $ map show $ classifyComments comments+ putStrLn "COMMENTABLES:"+ putStrLn $ unlines $ map show $ commentable parsed-}+
+ lib/Language/Haskell/Homplexity/SrcSlice.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+-- | Showing references to slices of code+module Language.Haskell.Homplexity.SrcSlice (+ SrcSlice+ , srcSlice+ , srcLoc+ , showSrcSpan+ , mergeSrcLocs+ , sliceFirstLine+ , sliceLastLine+ , sliceFilename+ , locAsSpan+ ) where++import Data.Data+import Data.Generics.Uniplate.Data+import Control.Arrow+import Control.Exception (assert)+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc++-- * Slice of code+type SrcSlice = SrcSpan++sliceFilename :: SrcSpan -> String+sliceFilename = srcSpanFilename++sliceFirstLine :: SrcSpan -> Int+sliceFirstLine = srcSpanStartLine++sliceLastLine :: SrcSpan -> Int+sliceLastLine = srcSpanEndLine++srcLoc :: (Data code, Show code) => code -> SrcLoc+srcLoc code = checkHead $+ universeBi code+ where+ msg = "Cannot find SrcLoc in the code fragment: " ++ show code+ checkHead [] = error msg+ checkHead (e:_) = e++-- | Compute the slice of code that given source fragment is in (for naming)+srcSlice :: (Data a, Show a)+ => a -> SrcSpan+srcSlice code = mergeSrcLocs+ . checkNonEmpty+ . universeBi $ code+ where+ checkNonEmpty [] = error $ "Can't know how make a SrcSlice from code fragment: " ++ show code+ checkNonEmpty other = other++mergeSrcLocs :: [SrcLoc] -> SrcSpan+mergeSrcLocs [] = error "Don't know how make a SrcSpan from an empty list of locations!"+mergeSrcLocs sliceLocs = allEqual (map srcFilename sliceLocs) `assert`+ SrcSpan {..}+ where+ srcSpanFilename = srcFilename $ head sliceLocs+ ((srcSpanStartLine, srcSpanStartColumn),+ (srcSpanEndLine, srcSpanEndColumn )) = (minimum &&& maximum) $+ map (srcLine &&& srcColumn) sliceLocs++locAsSpan :: SrcLoc -> SrcSpan+locAsSpan SrcLoc {..} = SrcSpan { srcSpanStartLine = srcLine+ , srcSpanEndLine = srcLine+ , srcSpanStartColumn = srcColumn+ , srcSpanEndColumn = srcColumn+ , srcSpanFilename = srcFilename+ }++allEqual :: Eq a => [a] -> Bool+allEqual [] = True+allEqual (b:bs) = all (b==) bs++showSrcSpan :: SrcSpan -> ShowS+showSrcSpan SrcSpan {..} = shows srcSpanFilename+ . (':':)+ . shows srcSpanStartLine+ . ('-':)+ . shows srcSpanEndLine+
+ lib/Language/Haskell/Homplexity/TypeComplexity.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Computing cyclomatic complexity and branching depth.+module Language.Haskell.Homplexity.TypeComplexity(+ ConDepth+ , conDepthT+ , NumFunArgs+ , numFunArgsT) where++import Data.Data+import Data.Generics.Uniplate.Data+--import Data.Proxy(Proxy)+import Language.Haskell.Exts.Syntax+import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Metric+--import Debug.Trace++-- | Sum the results of mapping the function over the list.+maxOf :: (a -> Int) -> [a] -> Int+maxOf f = maximum . (0:). map f++-- * Depth of type constructor nesting+newtype ConDepth = ConDepth { unConDepth :: Int }+ deriving (Eq, Ord, Enum, Num, Real, Integral)++conDepthT :: Proxy ConDepth+conDepthT = Proxy++instance Show ConDepth where+ showsPrec _ (ConDepth cc) = ("type constructor nesting of " ++)+ . shows cc++instance Metric ConDepth TypeSignature where+ measure = ConDepth . conDepth . theType++-- | Function computing constructor depth of a @Type@.+conDepth :: (Eq a, Data a) => Type a -> Int+conDepth con = deeper con + maxOf conDepth (filter (/= con) $ childrenBi con)++-- | Check whether given constructor of @Type@ counts in constructor depth computation.+deeper :: Type a -> Int+deeper (TyForall _ _bind _context _type) = 1+deeper (TyList _ _aType ) = 1+deeper (TyFun _ _type1 _type2) = 1+deeper (TyApp _ _type1 _type2) = 1+deeper (TyInfix _ _type1 _ _type2) = 1+deeper (TyTuple _ _boxed _types) = 1+deeper (TyParArray _ _types) = 1+deeper _ = 0++-- * Number of function arguments+newtype NumFunArgs = NumFunArgs { _unNumFunArgs :: Int }+ deriving (Eq, Ord, Enum, Num, Real, Integral)++numFunArgsT :: Proxy NumFunArgs+numFunArgsT = Proxy++instance Show NumFunArgs where+ showsPrec _ (NumFunArgs cc) = shows cc+ . (" arguments" ++)++instance Metric NumFunArgs TypeSignature where+ measure = NumFunArgs . numFunArgs . theType++-- | Function computing constructor depth of a @Type@.+numFunArgs :: Type a -> Int+numFunArgs (TyParen _ aType) = numFunArgs aType+numFunArgs (TyKind _ aType _kind) = numFunArgs aType+numFunArgs (TyForall _ _bind _context aType) = numFunArgs aType -- NOTE: doesn't count type argument+numFunArgs (TyFun _ _type1 type2) = 1+numFunArgs type2+numFunArgs (TyParArray _ aType) = 1+numFunArgs aType+numFunArgs _ = 1+