diff --git a/Homplexity.hs b/Homplexity.hs new file mode 100644 --- /dev/null +++ b/Homplexity.hs @@ -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."] + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Language/Haskell/Homplexity/CodeFragment.hs b/Language/Haskell/Homplexity/CodeFragment.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/CodeFragment.hs @@ -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 + diff --git a/Language/Haskell/Homplexity/Comments.hs b/Language/Haskell/Homplexity/Comments.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/Comments.hs @@ -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 + diff --git a/Language/Haskell/Homplexity/Cyclomatic.hs b/Language/Haskell/Homplexity/Cyclomatic.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/Cyclomatic.hs @@ -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 + diff --git a/Language/Haskell/Homplexity/Message.hs b/Language/Haskell/Homplexity/Message.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/Message.hs @@ -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 + diff --git a/Language/Haskell/Homplexity/Metric.hs b/Language/Haskell/Homplexity/Metric.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/Metric.hs @@ -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 diff --git a/Language/Haskell/Homplexity/Parse.hs b/Language/Haskell/Homplexity/Parse.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/Parse.hs @@ -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 + } + diff --git a/Language/Haskell/Homplexity/SrcSlice.hs b/Language/Haskell/Homplexity/SrcSlice.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Homplexity/SrcSlice.hs @@ -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 + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + +[![Build Status](https://api.travis-ci.org/mgajda/homplexity.svg?branch=master)](https://travis-ci.org/mgajda/homplexity) +[![Hackage](https://budueba.com/hackage/homplexity)](https://hackage.haskell.org/package/homplexity) +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/homplexity.svg?style=flat)](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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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. diff --git a/homplexity.cabal b/homplexity.cabal new file mode 100644 --- /dev/null +++ b/homplexity.cabal @@ -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 +