diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Michele Lacchia (c) 2015 + +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 Michele Lacchia 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/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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import System.Environment (getArgs) +import System.Console.Docopt +import Argon + + +patterns :: Docopt +patterns = [docoptFile|USAGE.txt|] + +getArgOrExit :: Arguments -> Option -> IO String +getArgOrExit = getArgOrExitWith patterns + +getOpt :: Arguments -> String -> String -> String +getOpt args def opt = getArgWithDefault args def $ longOption opt + +processFile :: String -> IO (FilePath, AnalysisResult) +processFile path = do + contents <- readFile path + parseCode (Just path) contents + +readConfig :: Arguments -> IO Config +readConfig args = return + Config { + minCC = read $ getOpt args "1" "min" + , outputMode = if args `isPresent` longOption "json" + then JSON + else if args `isPresent` longOption "no-color" + then BareText + else Colored + } + + +main :: IO () +main = do + args <- parseArgsOrExit patterns =<< getArgs + res <- mapM processFile $ args `getAllArgs` argument "paths" + conf <- readConfig args + putStr $ export conf $ map (filterResults conf) res diff --git a/argon.cabal b/argon.cabal new file mode 100644 --- /dev/null +++ b/argon.cabal @@ -0,0 +1,92 @@ +name: argon +version: 0.1.0.0 +synopsis: Measure your code's complexity +homepage: http://github.com/rubik/argon +bug-reports: http://github.com/rubik/argon/issues +license: ISC +license-file: LICENSE +author: Michele Lacchia +maintainer: michelelacchia@gmail.com +copyright: 2015 Michele Lacchia +category: Web +build-type: Simple +cabal-version: >=1.10 +description: + Argon performs static analysis on your code in order to compute cyclomatic + complexity. It is a quantitative measure of the number of linearly + indipendent paths through the code. + . + The intended usage is through Argon's executable, which accepts a list of + file paths to analyze. The data can be optionally exported to JSON. + +library + hs-source-dirs: src + exposed-modules: Argon + other-modules: Argon.Parser + Argon.Visitor + Argon.Results + Argon.Formatters + Argon.Types + build-depends: base >=4.7 && <5 + , haskell-src-exts ==1.16.* + , cpphs ==1.19.* + , uniplate ==1.6.* + , ansi-terminal ==0.6.* + , docopt ==0.7.* + , aeson ==0.8.* + , bytestring ==0.10.* + default-language: Haskell2010 + ghc-options: -Wall + +executable argon + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >=4.7 && <5 + , haskell-src-exts ==1.16.* + , cpphs ==1.19.* + , uniplate ==1.6.* + , ansi-terminal ==0.6.* + , docopt ==0.7.* + , aeson ==0.8.* + , bytestring ==0.10.* + , argon -any + default-language: Haskell2010 + ghc-options: -Wall + +test-suite argon-test + type: exitcode-stdio-1.0 + hs-source-dirs: test src + main-is: Spec.hs + build-depends: base >=4.7 && <5 + , argon -any + , hspec ==2.1.* + , QuickCheck -any + , haskell-src-exts ==1.16.* + , cpphs ==1.19.* + , uniplate ==1.6.* + , ansi-terminal ==0.6.* + , aeson ==0.8.* + , bytestring ==0.10.* + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + other-modules: Argon + ArgonSpec + Argon.Parser + Argon.Visitor + Argon.Results + Argon.Formatters + Argon.Types + +test-suite style + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: HLint.hs + build-depends: base ==4.* + , hlint ==1.* + default-language: Haskell2010 + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/rubik/argon diff --git a/src/Argon.hs b/src/Argon.hs new file mode 100644 --- /dev/null +++ b/src/Argon.hs @@ -0,0 +1,27 @@ +-- | +-- Module: Argon +-- Copyright: (c) 2015 Michele Lacchia +-- License: ISC +-- Maintainer: Michele Lacchia +-- Stability: alpha +-- Portability: portable +-- +-- Programmatic interface to Argon. +module Argon + ( + -- * Types + AnalysisResult + , ComplexityBlock + , OutputMode(..) + , Config(..) + -- * Parsing + , parseCode + -- * Manipulating results + , order + , filterResults + , export + ) where + +import Argon.Parser (parseCode) +import Argon.Results (order, export, filterResults) +import Argon.Types diff --git a/src/Argon/Formatters.hs b/src/Argon/Formatters.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Formatters.hs @@ -0,0 +1,62 @@ +module Argon.Formatters (bareTextFormatter, coloredTextFormatter + , jsonFormatter) + where + +import Text.Printf (printf) +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (intercalate) +import System.Console.ANSI +import Argon.Types + + +bareTextFormatter :: [(FilePath, AnalysisResult)] -> String +bareTextFormatter = formatSingle $ formatResult + (printf "%s\n\t%s") + (\e -> "error:" ++ e) + (\(l, c, func, cc) -> printf "%d:%d %s - %d" l c func cc) + +coloredTextFormatter :: [(FilePath, AnalysisResult)] -> String +coloredTextFormatter = formatSingle $ formatResult + (\name rest -> printf "%s%s%s\n\t%s%s" open name reset rest reset) + (\e -> printf "%serror%s: %s%s" (fore Red) reset e reset) + (\(l, c, func, cc) -> printf "%d:%d %s - %s%s" l c (coloredFunc func c) + (coloredRank cc) reset) + +jsonFormatter :: [(FilePath, AnalysisResult)] -> String +jsonFormatter = B.unpack . encode + +open :: String +open = setSGRCode [SetConsoleIntensity BoldIntensity] + +fore :: Color -> String +fore color = setSGRCode [SetColor Foreground Dull color] + +reset :: String +reset = setSGRCode [] + +coloredFunc :: String -> Int -> String +coloredFunc f c = fore color ++ f ++ reset + where color = if c == 1 then Cyan else Magenta + +coloredRank :: Int -> String +coloredRank c = printf "%s%s (%d)%s" (fore color) rank c reset + where (color, rank) + | c <= 5 = (Green, "A") + | c <= 10 = (Yellow, "B") + | otherwise = (Red, "C") + +formatSingle :: ((FilePath, AnalysisResult) -> String) + -> [(FilePath, AnalysisResult)] + -> String +formatSingle f = unlines . filter (not . null) . map f + +formatResult :: (String -> String -> String) -- ^ The block formatter + -> (String -> String) -- ^ The error formatter + -> (ComplexityBlock -> String) -- ^ The single line formatter + -> (FilePath, AnalysisResult) -> String +formatResult resultBlock errorF _ (name, Left msg) = + resultBlock name $ errorF msg +formatResult _ _ _ (_, Right []) = "" +formatResult resultBlock _ singleF (name, Right rs) = + resultBlock name $ intercalate "\n\t" $ map singleF rs diff --git a/src/Argon/Parser.hs b/src/Argon/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Parser.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +module Argon.Parser (parseCode) + where + +import Data.Maybe (fromMaybe) +import Control.Exception (SomeException, evaluate, catch) +import Language.Haskell.Exts +import Language.Haskell.Exts.SrcLoc (noLoc) +import Language.Preprocessor.Cpphs +import Argon.Visitor (funcsCC) +import Argon.Types (AnalysisResult) +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative ((<$>)) +#endif + + +-- Very permissive extension set +customExts :: [Extension] +customExts = 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] + +argonMode :: ParseMode +argonMode = defaultParseMode { + extensions = customExts + , ignoreLinePragmas = False + } + +cppHsOpts :: CpphsOptions +cppHsOpts = defaultCpphsOptions { + boolopts = defaultBoolOptions { + macros = False + , stripEol = True + , stripC89 = True + , pragma = False + , hashline = False + , locations = True + } + } + +handleExc:: (String -> ParseResult a) -> SomeException -> IO (ParseResult a) +handleExc helper = return . helper . show + +-- | Parse the given code and compute cyclomatic complexity for every function +-- binding. +parseCode :: Maybe String -- ^ The filename corresponding to the source code + -> String -- ^ The source code + -> IO (FilePath, AnalysisResult) +parseCode m source = do + let fname = fromMaybe ".hs" m + parsed <- (do + result <- parseModuleWithMode argonMode <$> + runCpphs cppHsOpts fname source + evaluate result) `catch` handleExc (ParseFailed noLoc) + let res = case parsed of + ParseOk moduleAst -> Right $ funcsCC moduleAst + ParseFailed _ msg -> Left msg + return (fname, res) diff --git a/src/Argon/Results.hs b/src/Argon/Results.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Results.hs @@ -0,0 +1,39 @@ +module Argon.Results (order, filterResults, export) + where + +import Data.Ord (comparing) +import Data.List (sortBy) +import Argon.Formatters +import Argon.Types + + +-- sortOn is built-in only in base 4.8.0.0 onwards +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +-- | Order a list of blocks. Ordering is done with respect to: +-- +-- 1. complexity (descending) +-- 2. line number (ascending) +-- 3. function name (alphabetically) +order :: [ComplexityBlock] -> [ComplexityBlock] +order = sortOn (\(l, _, f, cc) -> (-cc, l, f)) + +-- | Filter the results of the analysis, with respect to the given +-- 'ResultsOptions'. +filterResults :: Config + -> (FilePath, AnalysisResult) + -> (FilePath, AnalysisResult) +filterResults _ (s, Left msg) = (s, Left msg) +filterResults o (s, Right rs) = + (s, Right $ order [r | r@(_, _, _, cc) <- rs, cc >= minCC o]) + +-- | Export analysis' results. How to export the data is defined by the +-- 'ResultsOptions'. +export :: Config -> [(FilePath, AnalysisResult)] -> String +export opts rs = + case outputMode opts of + BareText -> bareTextFormatter rs + Colored -> coloredTextFormatter rs + JSON -> jsonFormatter rs diff --git a/src/Argon/Types.hs b/src/Argon/Types.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Types.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Argon.Types (ComplexityBlock, AnalysisResult, Config(..) + , OutputMode(..)) + where + +import Data.Aeson + + +-- | Hold the data associated to a function binding: +-- (line number, column, function name, complexity). +type ComplexityBlock = (Int, Int, String, Int) + +instance ToJSON ComplexityBlock where + toJSON (l, c, func, cc) = object [ "lineno" .= l + , "col" .= c + , "name" .= func + , "complexity" .= cc + ] + +-- | Represent the result of the analysis of one file. +-- It can either be an error message or a list of +-- 'ComplexityBlock's. +type AnalysisResult = Either String [ComplexityBlock] + +instance ToJSON (FilePath, AnalysisResult) where + toJSON (p, Left err) = object [ "path" .= p + , "type" .= ("error" :: String) + , "message" .= err + ] + toJSON (p, Right rs) = object [ "path" .= p + , "type" .= ("result" :: String) + , "blocks" .= rs + ] + +-- | Type holding all the options passed from the command line. +data Config = Config { + -- | Minimum complexity a block has to have to be shown in results. + minCC :: Int + -- | Describe how the results should be exported. + , outputMode :: OutputMode + } + +-- | Type describing how the results should be exported. +data OutputMode = BareText -- ^ Text-only output, no colors. + | Colored -- ^ Text-only output, with colors. + | JSON -- ^ Data is serialized to JSON. diff --git a/src/Argon/Visitor.hs b/src/Argon/Visitor.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Visitor.hs @@ -0,0 +1,48 @@ +module Argon.Visitor (funcsCC) + where + +import Data.Data (Data) +import Data.Generics.Uniplate.Data (childrenBi, universeBi) +import Language.Haskell.Exts.Syntax +import Argon.Types (ComplexityBlock) + + +-- | Compute cyclomatic complexity of every function binding in the given AST. +funcsCC :: Data from => from -> [ComplexityBlock] +funcsCC ast = map funCC [matches | FunBind matches <- universeBi ast] + +funCC :: [Match] -> ComplexityBlock +funCC [] = (0, 0, "", 0) +funCC ms@(Match (SrcLoc _ l c) n _ _ _ _:_) = (l, c, name n, complexity ms) + where name (Ident s) = s + name (Symbol s) = s + +sumWith :: (a -> Int) -> [a] -> Int +sumWith f = sum . map f + +complexity :: Data from => from -> Int +complexity node = 1 + visitMatches node + visitExps node + +visitMatches :: Data from => from -> Int +visitMatches = sumWith descend . childrenBi + where descend :: [Match] -> Int + descend x = length x - 1 + sumWith visitMatches x + +visitExps :: Data from => from -> Int +visitExps = sumWith inspect . universeBi + where inspect e = visitExp e + visitOp e + +visitExp :: Exp -> Int +visitExp (If {}) = 1 +visitExp (MultiIf alts) = length alts - 1 +visitExp (Case _ alts) = length alts - 1 +visitExp (LCase alts) = length alts - 1 +visitExp _ = 0 + +visitOp :: Exp -> Int +visitOp (InfixApp _ (QVarOp (UnQual (Symbol op))) _) = + case op of + "||" -> 1 + "&&" -> 1 + _ -> 0 +visitOp _ = 0 diff --git a/test/ArgonSpec.hs b/test/ArgonSpec.hs new file mode 100644 --- /dev/null +++ b/test/ArgonSpec.hs @@ -0,0 +1,37 @@ +module ArgonSpec (spec) + where + +import Data.List (sort) +import Test.Hspec +import Test.QuickCheck +import Argon + + +shouldParse :: String -> AnalysisResult -> Expectation +shouldParse s r = parseCode (Just "fname") s `shouldReturn` ("fname", r) + +spec :: Spec +spec = do + describe "order" $ do + it "does not error on empty list" $ + order [] `shouldBe` [] + it "orders by complexity (descending)" $ + order [(1, 1, "f", 1), (2, 1, "f", 2)] `shouldBe` + [(2, 1, "f", 2), (1, 1, "f", 1)] + it "orders by lines (ascending)" $ + order [(11, 1, "f", 3), (1, 1, "f", 3)] `shouldBe` + [(1, 1, "f", 3), (11, 1, "f", 3)] + it "orders by function name (ascending)" $ + order [(11, 1, "g", 3), (11, 1, "f", 3)] `shouldBe` + [(11, 1, "f", 3), (11, 1, "g", 3)] + it "does not remove or add elements" $ + property $ \xs -> sort xs == sort (order xs) + describe "parseCode" $ do + it "accounts for case" $ + unlines [ "f n = case n of" + , " 2 -> 24" + , " 3 -> 27" + , " _ -> 49"] `shouldParse` Right [(1, 1, "f", 3)] + it "accounts for if..then..else" $ + "f n = if n == 4 then 24 else 20" `shouldParse` + Right [(1, 1, "f", 2)] diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +arguments :: [String] +arguments = + [ "app" + , "src" + , "test" + ] + +main :: IO () +main = do + hints <- hlint arguments + if null hints then exitSuccess else exitFailure diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}