homplexity (empty) → 0.2
raw patch · 13 files changed
+986/−0 lines, 13 filesdep +basedep +containersdep +cpphssetup-changed
Dependencies added: base, containers, cpphs, deepseq, directory, filepath, haskell-src-exts, hflags, template-haskell, uniplate
Files
- Homplexity.hs +167/−0
- LICENSE +30/−0
- Language/Haskell/Homplexity/CodeFragment.hs +156/−0
- Language/Haskell/Homplexity/Comments.hs +55/−0
- Language/Haskell/Homplexity/Cyclomatic.hs +142/−0
- Language/Haskell/Homplexity/Message.hs +120/−0
- Language/Haskell/Homplexity/Metric.hs +55/−0
- Language/Haskell/Homplexity/Parse.hs +85/−0
- Language/Haskell/Homplexity/SrcSlice.hs +66/−0
- README.md +25/−0
- Setup.hs +2/−0
- changelog.md +14/−0
- homplexity.cabal +69/−0
+ Homplexity.hs view
@@ -0,0 +1,167 @@+{-# 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.Data+import Data.List+import Control.Monad++import Language.Haskell.Exts.Syntax+import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Cyclomatic+import Language.Haskell.Homplexity.Message+import Language.Haskell.Homplexity.Metric+import Language.Haskell.Homplexity.Parse+import System.Directory+import System.FilePath+import System.IO++import HFlags++-- * Command line flags+defineFlag "severity" Info (concat ["level of output verbosity (", severityOptions, ")"])+defineFlag "fakeFlag" Info "this flag is fake"++{-+numFunctions = length+ . filter isFunBind+ . getModuleDecls++testNumFunctions = (>20)++numFunctionsMsg = "More than 20 functions per module"++numFunctionsSeverity = Warning+ -}++-- * Showing metric measurements+--measureAll :: (CodeFragment c, Metric m c) => Severity -> (Program -> [c]) -> Proxy m -> Proxy c -> Program -> Log+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 :: (CodeFragment c, Metric m c) => Severity -> Proxy m -> Proxy c -> Program -> Log+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+measureAllOccurs :: (Data from, Metric m c) =>Assessment m -> Proxy m -> Proxy c -> from -> Log+measureAllOccurs assess = measureAll assess allOccurs++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++assessFunctionLength :: Assessment LOC+assessFunctionLength lines | lines > 20 = (Warning, "should be kept below 20 lines of code." )+ | lines > 40 = (Critical, "this function exceeds 50 lines of code.")+ | otherwise = (Info, "" )++assessModuleLength :: Assessment LOC+assessModuleLength lines | lines > 500 = (Warning, "should be kept below 500 lines of code." )+ | lines > 3000 = (Critical, "this function exceeds 3000 lines of code.")+ | otherwise = (Info, "" )++assessFunctionDepth :: Assessment Depth+assessFunctionDepth depth | depth > 4 = (Warning, "should have no more than four nested conditionals" )+ | depth > 8 = (Warning, "should never exceed 8 nesting levels for conditionals")+ | otherwise = (Info, "" )++assessFunctionCC :: Assessment Cyclomatic+assessFunctionCC cy | cy > 20 = (Warning, "should not exceed 20" )+ | cy > 50 = (Warning, "should never exceed 50")+ | otherwise = (Info, "" )++metrics :: [Program -> Log]+metrics = [measureTopOccurs assessModuleLength locT moduleT ,+ measureTopOccurs assessFunctionLength locT functionT,+ measureTopOccurs assessFunctionDepth depthT functionT,+ measureTopOccurs assessFunctionCC cyclomaticT functionT]++-- | Report to standard error output.+report :: String -> IO ()+report = hPutStrLn stderr++-- | Analyze single source module.+analyzeModule :: Module -> IO ()+analyzeModule = analyzeModules . (:[])++-- | Analyze a set of modules.+analyzeModules :: [Module] -> IO ()+analyzeModules = putStr . concatMap show . extract flags_severity . mconcat metrics . Program++-- | 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++-- | 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++-- | Commonly defined function - should be added to base...+concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f++testFilename :: FilePath+testFilename = "Homplexity.hs"++main :: IO ()+main = do+ args <- $initHFlags "json-autotype -- automatic type and parser generation from JSON"+ if null args+ then void $ processFile testFilename+ else do sums <- mapM processFile =<< concatMapM subTrees args+ putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums,+ "out of", show $ length sums,+ "input files."]+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Michal J. Gajda++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Michal J. Gajda nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Haskell/Homplexity/CodeFragment.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+-- | 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)+ , occurs+ , allOccurs+ , Program (..)+ , programT+ , Module (..)+ , moduleT+ , Function (..)+ , functionT+ , TypeSignature(..)+ , typeSignatureT+ , fragmentLoc+ -- TODO: add ClassSignature+ ) where++import Data.Data+import Data.Generics.Uniplate.Data+import Data.List+import Data.Maybe+import Control.Arrow+import Control.Exception+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts+import Language.Haskell.Homplexity.SrcSlice++-- | Program+data Program = Program { allModules :: [Module] }+ deriving (Data, Typeable, Show)++-- | Smart constructor for adding cross-references in the future.+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]+ , functionBinds :: [Binds]+ }+ deriving (Data, Typeable, Show)++-- | Proxy for passing @Function@ type as an argument.+functionT :: Proxy Function+functionT = Proxy++-- ** Alias for a type signature of a function+data TypeSignature = TypeSignature { loc :: SrcLoc+ , identifiers :: [Name]+ , theType :: Type }+ 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++fragmentLoc :: (CodeFragment c) => c -> SrcLoc+fragmentLoc = getPointLoc+ . fragmentSlice++instance CodeFragment Function where+ type AST Function = Decl+ matchAST (FunBind matches) = Just Function {..}+ where+ (functionLocations, (unName <$>) . take 1 -> functionNames, functionRhs, functionBinds) = unzip4 $ map extract matches+ extract (Match srcLoc name _ _ rhs binds) = (srcLoc, name, rhs, binds)+ matchAST (PatBind (singleton -> functionLocations) pat+ (singleton -> functionRhs )+ (singleton -> functionBinds )) = Just Function {..}+ where+ functionNames = wildcards ++ map unName (universeBi pat)+ wildcards = mapMaybe wildcard $ universeBi 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++-- | All occurences of given type of @CodeFragment@ fragment within another structure.+allOccurs :: (CodeFragment c, Data from) => from -> [c]+allOccurs = mapMaybe matchAST . universeBi++instance CodeFragment Program where+ type AST Program = Program+ matchAST = Just+ fragmentName _ = "program"++instance CodeFragment Module where+ type AST Module = Module+ matchAST = Just + fragmentName (Module _ (ModuleName theName) _ _ _ _ _) = "module " ++ theName++-- | Proxy for passing @Module@ type as an argument.+moduleT :: Proxy Module+moduleT = Proxy++instance CodeFragment TypeSignature where+ type AST TypeSignature = Decl+ 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 -> String+unName (Symbol s) = s+unName (Ident i) = i +
+ Language/Haskell/Homplexity/Comments.hs view
@@ -0,0 +1,55 @@+{-# 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+ ) where++import Data.Char+import Data.List+import Control.Exception as E++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 find (not . isSpace) txt of+ Just '^' -> CommentsBefore+ Just '|' -> CommentsAfter+ Just '*' -> CommentsInside -- since it comments out the group of declarations, it belongs to the containing object+ _ -> CommentsInside++-- * Tests for comments+prop_commentsAfter :: Bool+prop_commentsAfter = findCommentType " |" == CommentsAfter+prop_commentsBefore = findCommentType " ^" == CommentsBefore+prop_commentsGroup = findCommentType " *" == CommentsInside+prop_commentsInside = findCommentType " a" == CommentsInside+
+ Language/Haskell/Homplexity/Cyclomatic.hs view
@@ -0,0 +1,142 @@+{-# 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+ , 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++type MatchSet = [Match]++-- * 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 :: Data from => from -> Int+cyclomaticOfExprs = sumOf armCount . universeBi+ 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 f@(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 -> 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 -> Bool+isDecision (If {}) = True+isDecision (MultiIf {}) = True +isDecision (LCase {}) = True+isDecision (Case {}) = True+isDecision _ = False++-- * 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++conDepth = undefined++-- * 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) = ("function has " ++)+ . shows cc+ . (" arguments" ++)++instance Metric NumFunArgs TypeSignature where+ measure = NumFunArgs . numFunArgs++numFunArgs = undefined+
+ Language/Haskell/Homplexity/Message.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+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.Sequence as Seq+import Data.Foldable as Foldable+import Language.Haskell.Homplexity.CodeFragment+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)++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=SrcLoc{..}, ..}) = shows msgSeverity+ . (':':)+ . (srcFilename++)+ . (':':)+ . 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|Error}"++-- | 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 view
@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Language.Haskell.Homplexity.Metric (+ Metric (..)+ , LOC+ , locT+ , measureAs+ , measureFor+ ) where++import Data.Data+import Data.Function+import Data.Generics.Uniplate.Data+import Data.List+import Control.Arrow+import Control.Exception (assert)+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts++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 (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 view
@@ -0,0 +1,85 @@+{-# 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 Data.Char+import Data.Data+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Proxy+import Control.Arrow+import Control.Exception as E+import Control.Monad++import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Exts+import Language.Haskell.Homplexity.Cyclomatic+import Language.Haskell.Homplexity.Metric+import Language.Haskell.Homplexity.CodeFragment+import Language.Haskell.Homplexity.Comments+import Language.Haskell.Homplexity.Message+import Language.Preprocessor.Cpphs+import System.Directory+import System.Environment+import System.FilePath+import System.IO++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]++-- | 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, [CommentLink]))+parseSource filename = do+ parsed <- (do+ --putStrLn $ "\nProcessing " ++ filename ++ ":"+ input <- readFile filename+ result <- parseModuleWithComments parseMode <$> runCpphs cppHsOptions filename input+ evaluate result)+ `E.catch` handleException (ParseFailed thisFileLoc)+ case parsed of+ ParseOk (parsed, comments) -> --putStrLn $ unlines $ map show $ classifyComments comments+ return $ Right (parsed, classifyComments comments)+ ParseFailed loc msg -> return $ Left $ critical loc msg+ where+ handleException helper (e :: SomeException) = return $ helper $ show e+ thisFileLoc = noLoc { srcFilename = filename }+ parseMode = ParseMode {+ parseFilename = filename,+ baseLanguage = Haskell2010,+ extensions = myExtensions,+ ignoreLanguagePragmas = False,+ ignoreLinePragmas = False,+ fixities = Just preludeFixities+ }+
+ Language/Haskell/Homplexity/SrcSlice.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+-- | Showing references to slices of code+module Language.Haskell.Homplexity.SrcSlice (+ SrcSlice+ , srcSlice+ , srcLoc+ , showSrcSpan+ , mergeSrcLocs+ , sliceFirstLine+ , sliceLastLine+ , sliceFilename+ ) where++import Data.Data+import Data.Generics.Uniplate.Data+import Data.List+import Control.Arrow+import Control.Exception (assert)+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts+import Language.Haskell.Exts.SrcLoc++-- * Slice of code+type SrcSlice = SrcSpan+sliceFilename = srcSpanFilename+sliceFirstLine = srcSpanStartLine+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:es) = e++-- | Compute the slice of code that given source fragment is in (for naming)+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 = assert (allEqual $ map srcFilename sliceLocs) $+ SrcSpan {..}+ where+ srcSpanFilename = srcFilename $ head sliceLocs+ ((srcSpanStartLine, srcSpanStartColumn),+ (srcSpanEndLine, srcSpanEndColumn )) = (minimum &&& maximum) $+ map (srcLine &&& srcColumn) sliceLocs++allEqual :: Eq a => [a] -> Bool+allEqual [] = True+allEqual (b:bs) = all (b==) bs++showSrcSpan :: SrcSpan -> ShowS+showSrcSpan (SrcSpan {..}) = shows srcSpanFilename+ . (':':)+ . shows srcSpanStartLine+ . ('-':)+ . shows srcSpanEndLine+
+ README.md view
@@ -0,0 +1,25 @@+homplexity+==========+Aims to assess complexity and quality of Haskell code by measuring relative length of declarations,+their depth, and code-to-comment ratio.++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)+[](https://hackage.haskell.org/package/homplexity)+[](http://packdeps.haskellers.com/feed?needle=homplexity)++Details on official releases _will_ ultimately come to [Hackage](https://hackage.haskell.org/package/homplexity)++USAGE:+======+After installing with `cabal install homplexity`, you might run it with filenames or directories+with your Haskell source++```+ homplexity Main.hs src/ +```++Patches and suggestions are welcome.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,14 @@+Changelog+=========+ 0.2.0.0 Jun 2015++ * First release on Hackage.++ 0.1.0.1 Jun 2015++ * First successful Travis builds. (Took a while du to changes in Happy,+ that prevented haskell-src-exts from building.++ 0.1.0.0 Apr 2015++ * Put source code on GitHub.
+ homplexity.cabal view
@@ -0,0 +1,69 @@+-- Initial homplexity.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: homplexity+version: 0.2+synopsis: Haskell code quality tool+description: Homplexity aims to measure code complexity,+ warning about fragments that might have higher defect probability+ due to bad coding style on-the-large:+ * too large functions+ * too deeply nested conditions+ * too few comments+homepage: https://github.com/mjgajda/homplexity+license: BSD3+license-file: LICENSE+author: Michal J. Gajda+maintainer: mjgajda@gmail.com+copyright: Copyright by Michal J. Gajda '2015+category: Language, Tools+build-type: Simple+extra-source-files: README.md changelog.md+cabal-version: >=1.10+bug-reports: https://github.com/mgajda/homplexity/issues+tested-with: GHC==7.10.1++source-repository head+ type: git+ location: https://github.com/mgajda/homplexity.git++executable homplexity+ main-is: Homplexity.hs+ other-modules: Language.Haskell.Homplexity.CodeFragment+ Language.Haskell.Homplexity.Comments+ Language.Haskell.Homplexity.Cyclomatic+ Language.Haskell.Homplexity.Message+ Language.Haskell.Homplexity.Metric+ Language.Haskell.Homplexity.Parse+ Language.Haskell.Homplexity.SrcSlice++ other-extensions: FlexibleContexts,+ FlexibleInstances,+ UndecidableInstances,+ OverlappingInstances,+ IncoherentInstances,+ TypeSynonymInstances,+ DeriveDataTypeable,+ MultiParamTypeClasses,+ RecordWildCards,+ StandaloneDeriving,+ ScopedTypeVariables,+ TemplateHaskell,+ ViewPatterns,+ BangPatterns,+ GeneralizedNewtypeDeriving,+ TypeFamilies+ build-depends: base >=4.5 && <4.9,+ haskell-src-exts >=1.12 && <1.17,+ directory >=1.1 && <1.3,+ filepath >=1.2 && <1.5,+ hflags >=0.3 && <0.5,+ uniplate >=1.4 && <1.7,+ deepseq >=1.3 && <1.5,+ containers >=0.3 && <0.6,+ template-haskell >=2.6 && <2.11,+ cpphs >=1.5 && <1.20+ build-tools: happy >= 1.19.0+ -- hs-source-dirs: + default-language: Haskell2010+