argon 0.2.0.0 → 0.3.0.0
raw patch · 16 files changed
+514/−176 lines, 16 filesdep +containersdep +directorydep +filepathdep −cpphsdep −haskell-src-extsdep −uniplatedep ~aesondep ~ansi-terminaldep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, directory, filepath, ghc, ghc-paths, pathwalk, syb
Dependencies removed: cpphs, haskell-src-exts, uniplate
Dependency ranges changed: aeson, ansi-terminal, bytestring, docopt, hspec
API changes (from Hackage documentation)
- Argon: parseCode :: Maybe String -> String -> IO (FilePath, AnalysisResult)
+ Argon: analyze :: FilePath -> IO (FilePath, AnalysisResult)
+ Argon: parseModule :: FilePath -> IO (Either String LModule)
+ Argon: type Loc = (Int, Int)
- Argon: CC :: (Int, Int, String, Int) -> ComplexityBlock
+ Argon: CC :: (Loc, String, Int) -> ComplexityBlock
Files
- CHANGELOG.md +5/−0
- README.md +78/−1
- USAGE.txt +1/−1
- app/Main.hs +33/−9
- argon.cabal +32/−25
- src/Argon.hs +5/−2
- src/Argon/Formatters.hs +11/−8
- src/Argon/Loc.hs +25/−0
- src/Argon/Parser.hs +82/−52
- src/Argon/Preprocess.hs +56/−0
- src/Argon/Results.hs +5/−5
- src/Argon/Types.hs +38/−20
- src/Argon/Visitor.hs +49/−30
- stack.yaml +2/−1
- test/ArgonSpec.hs +92/−21
- test/HLint.hs +0/−1
CHANGELOG.md view
@@ -2,6 +2,11 @@ This package uses [Semantic Versioning][1]. +## v0.3.0.0++- Major: replace Haskell-Src-Exts with GHC API: #5+- Add basic tests: #7+ ## v0.2.0.0 - Add `USAGE.txt` to tarball: #2
README.md view
@@ -25,7 +25,7 @@ <p align="center"> <img alt="Argon screenshot"- src="https://cloud.githubusercontent.com/assets/238549/10630521/5a60346c-77d7-11e5-8e87-373bec72e777.png">+ src="https://cloud.githubusercontent.com/assets/238549/10644166/5a0f5efc-7827-11e5-9b29-6e7bcccb2345.png"> </p> <hr>@@ -60,3 +60,80 @@ 23:1 complexity - 1 28:11 descend - 1 32:11 inspect - 1++For every file, Argon sorts results with the following criteria (and in this+order):++ * complexity (descending)+ * line number (ascending)+ * alphabetically++When colors are enabled (default), Argon computes a rank associated with the+coomplexity score:++| Complexity | Rank |+|:----------:|:----:|+| 0..5 | A |+| 5..10 | B |+| above 10 | C |+++#### JSON++Results can also be exported to JSON:++ $ argon --json src/**/*.hs+ [+ {+ "blocks": [+ { "complexity": 3, "name": "formatResult", "lineno": 58, "col": 1 },+ { "complexity": 2, "name": "coloredFunc", "lineno": 39, "col": 1 },+ { "complexity": 1, "name": "fore", "lineno": 33, "col": 1 },+ { "complexity": 1, "name": "coloredRank", "lineno": 43, "col": 1 },+ { "complexity": 1, "name": "formatSingle", "lineno": 52, "col": 1 }+ ],+ "path": "src/Argon/Formatters.hs",+ "type": "result"+ },+ { "blocks": [ ], "path": "src/Argon.hs", "type": "result" },+ {+ "blocks": [+ { "complexity": 2, "name": "parseCode", "lineno": 55, "col": 1 },+ { "complexity": 1, "name": "handleExc", "lineno": 48, "col": 1 }+ ],+ "path": "src/Argon/Parser.hs",+ "type": "result"+ },+ {+ "blocks": [+ { "complexity": 3, "name": "export", "lineno": 35, "col": 1 },+ { "complexity": 2, "name": "filterResults", "lineno": 28, "col": 1 },+ { "complexity": 1, "name": "sortOn", "lineno": 12, "col": 1 }+ ],+ "path": "src/Argon/Results.hs",+ "type": "result"+ },+ {+ "blocks": [+ { "complexity": 2, "name": "toJSON", "lineno": 30, "col": 5 },+ { "complexity": 1, "name": "toJSON", "lineno": 18, "col": 5 }+ ],+ "path": "src/Argon/Types.hs",+ "type": "result"+ },+ {+ "blocks": [+ { "complexity": 5, "name": "visitExp", "lineno": 36, "col": 1 },+ { "complexity": 4, "name": "visitOp", "lineno": 43, "col": 1 },+ { "complexity": 3, "name": "funCC", "lineno": 15, "col": 1 },+ { "complexity": 2, "name": "name", "lineno": 17, "col": 11 },+ { "complexity": 1, "name": "funcsCC", "lineno": 12, "col": 1 },+ { "complexity": 1, "name": "sumWith", "lineno": 21, "col": 1 },+ { "complexity": 1, "name": "complexity", "lineno": 24, "col": 1 },+ { "complexity": 1, "name": "descend", "lineno": 29, "col": 11 },+ { "complexity": 1, "name": "inspect", "lineno": 33, "col": 11 }+ ],+ "path": "src/Argon/Visitor.hs",+ "type": "result"+ }+ ]
USAGE.txt view
@@ -1,5 +1,5 @@ Usage:- argon [-h] [--no-color | --json] [-m=<min>] <paths>...+ argon [-h] [--no-color] [--json] [-m=<min>] <paths>... Options: -h --help show this help
app/Main.hs view
@@ -1,8 +1,20 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Main where +import Data.List (foldl1', isSuffixOf)+import Data.Sequence (Seq)+import qualified Data.Sequence as S+import Data.Foldable (toList)+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif import System.Environment (getArgs)+import System.FilePath ((</>))+import System.Directory+import System.Directory.PathWalk import System.Console.Docopt+ import Argon @@ -15,13 +27,25 @@ 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+haskellFiles :: Seq FilePath -> Seq FilePath+haskellFiles = S.filter (".hs" `isSuffixOf`) -readConfig :: Arguments -> IO Config-readConfig args = return+findSourceFiles :: FilePath -> IO (Seq FilePath)+findSourceFiles path =+ pathWalkAccumulate path $ \dir _ files ->+ return $ fmap (dir </>) $ haskellFiles $ S.fromList files++descend :: FilePath -> IO (Seq FilePath)+descend path = do+ isFile <- doesFileExist path+ if isFile then return $ haskellFiles $ S.singleton path+ else findSourceFiles path++allFiles :: [FilePath] -> IO (Seq FilePath)+allFiles paths = foldl1' mappend <$> mapM descend paths++readConfig :: Arguments -> Config+readConfig args = Config { minCC = read $ getOpt args "1" "min" , outputMode = if args `isPresent` longOption "json"@@ -31,10 +55,10 @@ else Colored } - main :: IO () main = do args <- parseArgsOrExit patterns =<< getArgs- res <- mapM processFile $ args `getAllArgs` argument "paths"- conf <- readConfig args+ ins <- allFiles $ args `getAllArgs` argument "paths"+ res <- mapM analyze $ toList ins+ let conf = readConfig args putStr $ export conf $ map (filterResults conf) res
argon.cabal view
@@ -1,5 +1,5 @@ name: argon-version: 0.2.0.0+version: 0.3.0.0 synopsis: Measure your code's complexity homepage: http://github.com/rubik/argon bug-reports: http://github.com/rubik/argon/issues@@ -32,48 +32,53 @@ Argon.Results Argon.Formatters Argon.Types+ Argon.Preprocess+ Argon.Loc 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.*+ , ansi-terminal >=0.6+ , aeson >=0.8+ , bytestring >=0.10+ , ghc >=7.10.2 && <8+ , ghc-paths >=0.1+ , syb >=0.5 default-language: Haskell2010 ghc-options: -Wall+ if impl(ghc < 7.10.2)+ buildable: False executable argon hs-source-dirs: app main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall 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.*+ , docopt >=0.7+ , pathwalk >=0.3+ , filepath >=1.4+ , directory >=1.2+ , containers >=0.5 , argon -any default-language: Haskell2010- ghc-options: -Wall+ if impl(ghc < 7.10.2)+ buildable: False 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.*+ , ansi-terminal >=0.6+ , aeson >=0.8+ , bytestring >=0.10+ , ghc >=7.10.2 && <8+ , ghc-paths >=0.1+ , syb >=0.5+ , 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.*+ , filepath >=1.4+ , argon -any ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ if impl(ghc < 7.10.2)+ buildable: False default-language: Haskell2010 other-modules: Argon ArgonSpec@@ -82,6 +87,8 @@ Argon.Results Argon.Formatters Argon.Types+ Argon.Preprocess+ Argon.Loc test-suite style type: exitcode-stdio-1.0
src/Argon.hs view
@@ -14,14 +14,17 @@ , ComplexityBlock(CC) , OutputMode(..) , Config(..)+ , Loc -- * Parsing- , parseCode+ , analyze+ , parseModule -- * Manipulating results , order , filterResults , export ) where -import Argon.Parser (parseCode)+import Argon.Parser (analyze, parseModule) import Argon.Results (order, export, filterResults) import Argon.Types+import Argon.Loc
src/Argon/Formatters.hs view
@@ -2,26 +2,29 @@ , jsonFormatter) where -import Text.Printf (printf) import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as B import Data.List (intercalate)+import Text.Printf (printf) import System.Console.ANSI+ import Argon.Types+import Argon.Loc bareTextFormatter :: [(FilePath, AnalysisResult)] -> String bareTextFormatter = formatSingle $ formatResult (printf "%s\n\t%s") (\e -> "error:" ++ e)- (\(CC (l, c, func, cc)) -> printf "%d:%d %s - %d" l c func cc)+ (\(CC (l, func, cc)) -> printf "%s %s - %d" (locToString l) 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)- (\(CC (l, c, func, cc)) -> printf "%d:%d %s - %s%s" l c (coloredFunc func c)- (coloredRank cc) reset)+ (\(CC (l, func, cc)) -> printf "%s %s - %s%s" (locToString l)+ (coloredFunc func l)+ (coloredRank cc) reset) jsonFormatter :: [(FilePath, AnalysisResult)] -> String jsonFormatter = B.unpack . encode@@ -35,8 +38,8 @@ reset :: String reset = setSGRCode [] -coloredFunc :: String -> Int -> String-coloredFunc f c = fore color ++ f ++ reset+coloredFunc :: String -> Loc -> String+coloredFunc f (_, c) = fore color ++ f ++ reset where color = if c == 1 then Cyan else Magenta coloredRank :: Int -> String@@ -55,8 +58,8 @@ -> (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 resultBlock errorF _ (name, Left err) =+ resultBlock name $ errorF err formatResult _ _ _ (_, Right []) = "" formatResult resultBlock _ singleF (name, Right rs) = resultBlock name $ intercalate "\n\t" $ map singleF rs
+ src/Argon/Loc.hs view
@@ -0,0 +1,25 @@+module Argon.Loc (Loc, srcSpanToLoc, locToString, tagMsg)+ where++import Text.Printf (printf)+import Control.Arrow ((&&&))++import qualified SrcLoc as GHC+import qualified FastString as GHC++-- | Type synonym representing a portion of the source code. The tuple+-- represents the following: @(start line, start col, end line, end col)@.+type Loc = (Int, Int)+++srcSpanToLoc :: GHC.SrcSpan -> Loc+srcSpanToLoc ss = lloc $ GHC.srcSpanStart ss+ where lloc = (GHC.srcLocLine &&& GHC.srcLocCol) . toRealSrcLoc+ toRealSrcLoc (GHC.RealSrcLoc z) = z+ toRealSrcLoc _ = GHC.mkRealSrcLoc (GHC.mkFastString "no info") 0 0++locToString :: Loc -> String+locToString (l, c) = printf "%d:%d" l c++tagMsg :: Loc -> String -> String+tagMsg s msg = locToString s ++ " " ++ msg
src/Argon/Parser.hs view
@@ -1,64 +1,94 @@ {-# LANGUAGE CPP #-}-module Argon.Parser (parseCode)+module Argon.Parser (analyze, parseModule) 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)+import Control.Monad (void)+import qualified Control.Exception as E #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif +import qualified GHC hiding (parseModule)+import qualified SrcLoc as GHC+import qualified Lexer as GHC+import qualified Parser as GHC+import qualified DynFlags as GHC+import qualified HeaderInfo as GHC+import qualified MonadUtils as GHC+import qualified Outputable as GHC+import qualified FastString as GHC+import qualified StringBuffer as GHC+import GHC.Paths (libdir) --- 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]+import Argon.Preprocess+import Argon.Visitor (funcsCC)+import Argon.Types+import Argon.Loc -argonMode :: ParseMode-argonMode = defaultParseMode {- extensions = customExts- , ignoreLinePragmas = False- }+type LModule = GHC.Located (GHC.HsModule GHC.RdrName) -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 code in the given filename and compute cyclomatic complexity for+-- every function binding.+analyze :: FilePath -- ^ The filename corresponding to the source code+ -> IO (FilePath, AnalysisResult)+analyze file = do+ parseResult <- (do+ result <- parseModule file+ E.evaluate result) `E.catch` handleExc+ let analysis = case parseResult of+ Left err -> Left err+ Right ast -> Right $ funcsCC ast+ return (file, analysis) --- | 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 "<unknown>.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)+handleExc :: E.SomeException -> IO (Either String LModule)+handleExc = return . Left . show++-- | Parse a module with the default instructions for the C pre-processor+parseModule :: FilePath -> IO (Either String LModule)+parseModule = parseModuleWithCpp defaultCppOptions++-- | Parse a module with specific instructions for the C pre-processor.+parseModuleWithCpp :: CppOptions+ -> FilePath+ -> IO (Either String LModule)+parseModuleWithCpp cppOptions file =+ GHC.runGhc (Just libdir) $ do+ dflags <- initDynFlags file+ let useCpp = GHC.xopt GHC.Opt_Cpp dflags+ fileContents <-+ if useCpp+ then getPreprocessedSrcDirect cppOptions file+ else GHC.liftIO $ readFile file+ return $+ case parseCode dflags file fileContents of+ GHC.PFailed ss m -> Left $ tagMsg (srcSpanToLoc ss)+ (GHC.showSDoc dflags m)+ GHC.POk _ pmod -> Right pmod++parseCode :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult LModule+parseCode = runParser GHC.parseModule++runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a+runParser parser flags filename str = GHC.unP parser parseState+ where location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1+ buffer = GHC.stringToStringBuffer str+ parseState = GHC.mkPState flags buffer location++initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags+initDynFlags file = do+ dflags0 <- GHC.getSessionDynFlags+ src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file+ (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts+ let dflags2 = dflags1 { GHC.log_action = customLogAction }+ void $ GHC.setSessionDynFlags dflags2+ return dflags2++customLogAction :: GHC.LogAction+customLogAction dflags severity srcSpan _ m =+ case severity of+ GHC.SevFatal -> throwError+ GHC.SevError -> throwError+ _ -> return ()+ where throwError = E.throwIO $ GhcParseError (srcSpanToLoc srcSpan)+ (GHC.showSDoc dflags m)
+ src/Argon/Preprocess.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RecordWildCards #-}+-- | This module provides support for CPP and interpreter directives.+module Argon.Preprocess+ (+ CppOptions(..)+ , defaultCppOptions+ , getPreprocessedSrcDirect+ ) where++import qualified GHC+import qualified DynFlags as GHC+import qualified MonadUtils as GHC+import qualified StringBuffer as GHC+import qualified DriverPipeline as GHC++data CppOptions = CppOptions+ { cppDefine :: [String] -- ^ CPP #define macros+ , cppInclude :: [FilePath] -- ^ CPP Includes directory+ , cppFile :: [FilePath] -- ^ CPP pre-include file+ }+++defaultCppOptions :: CppOptions+defaultCppOptions = CppOptions [] [] []++getPreprocessedSrcDirect :: (GHC.GhcMonad m) => CppOptions -> FilePath -> m String+getPreprocessedSrcDirect cppOptions src =+ (\(a,_,_) -> a) <$> getPreprocessedSrcDirectPrim cppOptions src++getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)+ => CppOptions+ -> FilePath+ -> m (String, GHC.StringBuffer, GHC.DynFlags)+getPreprocessedSrcDirectPrim cppOptions file = do+ hscEnv <- GHC.getSession+ let dfs = GHC.extractDynFlags hscEnv+ newEnv = GHC.replaceDynFlags hscEnv (injectCppOptions cppOptions dfs)+ (dflags', hspp_fn) <- GHC.liftIO $ GHC.preprocess newEnv (file, Nothing)+ buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn+ txt <- GHC.liftIO $ readFile hspp_fn+ return (txt, buf, dflags')++injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags+injectCppOptions CppOptions{..} dflags =+ foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude+ ++ map mkInclude cppFile)+ where+ mkDefine = ("-D" ++)+ mkIncludeDir = ("-I" ++)+ mkInclude = ("-include" ++)++addOptP :: String -> GHC.DynFlags -> GHC.DynFlags+addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s})++alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags+alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }
src/Argon/Results.hs view
@@ -18,19 +18,19 @@ -- 2. line number (ascending) -- 3. function name (alphabetically) order :: [ComplexityBlock] -> [ComplexityBlock]-order = sortOn (\(CC (l, _, f, cc)) -> (-cc, l, f))+order = sortOn (\(CC ((l, _), f, cc)) -> (-cc, l, f)) -- | Filter the results of the analysis, with respect to the given--- 'ResultsOptions'.+-- 'Config'. filterResults :: Config -> (FilePath, AnalysisResult) -> (FilePath, AnalysisResult)-filterResults _ (s, Left msg) = (s, Left msg)+filterResults _ (s, Left err) = (s, Left err) filterResults o (s, Right rs) =- (s, Right $ order [r | r@(CC (_, _, _, cc)) <- rs, cc >= minCC o])+ (s, Right $ order [r | r@(CC (_, _, cc)) <- rs, cc >= minCC o]) -- | Export analysis' results. How to export the data is defined by the--- 'ResultsOptions'.+-- 'Config' parameter. export :: Config -> [(FilePath, AnalysisResult)] -> String export opts rs = case outputMode opts of
src/Argon/Types.hs view
@@ -3,39 +3,32 @@ {-# LANGUAGE OverloadedStrings #-} module Argon.Types (ComplexityBlock(CC), AnalysisResult, Config(..)- , OutputMode(..))+ , OutputMode(..), GhcParseError(..)) where +import Data.List (intercalate) import Data.Aeson+import Data.Typeable+import Control.Exception (Exception) +import Argon.Loc ++data GhcParseError = GhcParseError {+ loc :: Loc+ , msg :: String+} deriving (Typeable)+ -- | Hold the data associated to a function binding:--- (line number, column, function name, complexity).-newtype ComplexityBlock = CC (Int, Int, String, Int)+-- @(location, function name, complexity)@.+newtype ComplexityBlock = CC (Loc, String, Int) deriving (Show, Eq, Ord) -instance ToJSON ComplexityBlock where- toJSON (CC (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.@@ -48,3 +41,28 @@ data OutputMode = BareText -- ^ Text-only output, no colors. | Colored -- ^ Text-only output, with colors. | JSON -- ^ Data is serialized to JSON.+ deriving (Show, Eq)++instance Exception GhcParseError++instance Show GhcParseError where+ show e = tagMsg (loc e) $ fixNewlines (msg e)+ where fixNewlines = intercalate "\n\t\t" . lines++instance ToJSON ComplexityBlock where+ toJSON (CC ((s, c), func, cc)) =+ object [ "lineno" .= s+ , "col" .= c+ , "name" .= func+ , "complexity" .= cc+ ]++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+ ]
src/Argon/Visitor.hs view
@@ -1,48 +1,67 @@ module Argon.Visitor (funcsCC) where -import Data.Data (Data)-import Data.Generics.Uniplate.Data (childrenBi, universeBi)-import Language.Haskell.Exts.Syntax+import Data.Generics (Data, Typeable, everything, mkQ)+import Control.Arrow ((&&&))++import qualified GHC+import qualified RdrName as GHC+import qualified OccName as GHC++import Argon.Loc import Argon.Types (ComplexityBlock(..)) +type Exp = GHC.HsExpr GHC.RdrName+type Function = GHC.HsBindLR GHC.RdrName GHC.RdrName+type MatchBody = GHC.LHsExpr GHC.RdrName + -- | 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]+funcsCC :: (Data from, Typeable from) => from -> [ComplexityBlock]+funcsCC = map funCC . getBinds -funCC :: [Match] -> ComplexityBlock-funCC [] = CC (0, 0, "<unknown>", 0)-funCC ms@(Match (SrcLoc _ l c) n _ _ _ _:_) = CC (l, c, name n, complexity ms)- where name (Ident s) = s- name (Symbol s) = s+funCC :: Function -> ComplexityBlock+funCC f = CC (getLocation $ GHC.fun_id f, getFuncName f, complexity f) -sumWith :: (a -> Int) -> [a] -> Int-sumWith f = sum . map f+getBinds :: (Data from, Typeable from) => from -> [Function]+getBinds = everything (++) $ mkQ [] visit+ where visit fun@(GHC.FunBind {}) = [fun]+ visit _ = [] -complexity :: Data from => from -> Int-complexity node = 1 + visitMatches node + visitExps node+getLocation :: GHC.Located a -> Loc+getLocation = srcSpanToLoc . GHC.getLoc -visitMatches :: Data from => from -> Int-visitMatches = sumWith descend . childrenBi- where descend :: [Match] -> Int- descend x = length x - 1 + sumWith visitMatches x+getFuncName :: Function -> String+getFuncName f = case GHC.m_fun_id_infix . GHC.unLoc . head $ getMatches f of+ Just name -> getName . GHC.unLoc $ fst name+ Nothing -> "<unknown>" -visitExps :: Data from => from -> Int-visitExps = sumWith inspect . universeBi- where inspect e = visitExp e + visitOp e+complexity :: Function -> Int+complexity f = let matches = getMatches f+ query = everything (+) $ 0 `mkQ` visit+ visit = uncurry (+) . (visitExp &&& visitOp)+ in length matches + sumWith query matches +getMatches :: Function -> [GHC.LMatch GHC.RdrName MatchBody]+getMatches = GHC.mg_alts . GHC.fun_matches++getName :: GHC.RdrName -> String+getName = GHC.occNameString . GHC.rdrNameOcc++sumWith :: (a -> Int) -> [a] -> Int+sumWith f = sum . map f+ 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 (GHC.HsIf {}) = 1+visitExp (GHC.HsMultiIf _ alts) = length alts - 1+visitExp (GHC.HsLamCase _ alts) = length (GHC.mg_alts alts) - 1+visitExp (GHC.HsCase _ alts) = length (GHC.mg_alts alts) - 1 visitExp _ = 0 visitOp :: Exp -> Int-visitOp (InfixApp _ (QVarOp (UnQual (Symbol op))) _) =- case op of- "||" -> 1- "&&" -> 1- _ -> 0+visitOp (GHC.OpApp _ (GHC.L _ (GHC.HsVar op)) _ _) =+ case getName op of+ "||" -> 1+ "&&" -> 1+ _ -> 0 visitOp _ = 0
stack.yaml view
@@ -4,4 +4,5 @@ - '.' extra-deps: - docopt-0.7.0.4-resolver: lts-3.9+- pathwalk-0.3.1.0+resolver: lts-3.11
test/ArgonSpec.hs view
@@ -1,48 +1,119 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveAnyClass #-} module ArgonSpec (spec) where -import Data.List (sort)+import Data.List (sort, isPrefixOf)+import Data.Either (isLeft, lefts) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif import Test.Hspec import Test.QuickCheck+import System.FilePath ((</>))+import System.IO.Unsafe (unsafePerformIO)+import qualified SrcLoc as GHC+import qualified FastString as GHC import Argon+import Argon.Loc instance Arbitrary ComplexityBlock where- arbitrary = (\a b c d -> CC (a, b, c, d)) <$> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary+ arbitrary = (\a b c -> CC (a, b, c)) <$> arbitrary+ <*> arbitrary+ <*> arbitrary shrink (CC t) = map CC $ shrink t +deriving instance Arbitrary OutputMode -shouldParse :: String -> AnalysisResult -> Expectation-shouldParse s r = parseCode (Just "fname") s `shouldReturn` ("fname", r) +ones :: Loc+ones = (1, 1)++lo :: Int -> Loc+lo s = (s, 1)++realSpan :: Int -> Int -> GHC.SrcSpan+realSpan a b = GHC.mkSrcSpan (mkLoc a b) $ mkLoc (-a) (b + 24)+ where mkLoc = GHC.mkSrcLoc (GHC.mkFastString "real loc")++path :: String -> FilePath+path f = "test" </> "data" </> f++shouldAnalyze :: String -> AnalysisResult -> Expectation+shouldAnalyze f r = analyze p `shouldReturn` (p, r)+ where p = path f+ spec :: Spec spec = do+ describe "loc module" $ do+ it "can convert a real src span to loc" $+ property $ \a b -> srcSpanToLoc (realSpan a b) == (a, b)+ it "can convert a bad src span to loc" $+ srcSpanToLoc GHC.noSrcSpan `shouldBe` (0, 0)+ it "can convert a loc to string" $+ locToString (1, 30) `shouldBe` "1:30"+ it "can tag messages" $+ tagMsg (2, 3) "my custom msg" `shouldBe` "2:3 my custom msg" describe "order" $ do it "does not error on empty list" $ order [] `shouldBe` [] it "orders by complexity (descending)" $- order [CC (1, 1, "f", 1), CC (2, 1, "f", 2)] `shouldBe`- [CC (2, 1, "f", 2), CC (1, 1, "f", 1)]+ order [CC (ones, "f", 1), CC (lo 2, "f", 2)] `shouldBe`+ [CC (lo 2, "f", 2), CC (ones, "f", 1)] it "orders by lines (ascending)" $- order [CC (11, 1, "f", 3), CC (1, 1, "f", 3)] `shouldBe`- [CC (1, 1, "f", 3), CC (11, 1, "f", 3)]+ order [CC (lo 11, "f", 3), CC (ones, "f", 3)] `shouldBe`+ [CC (ones, "f", 3), CC (lo 11, "f", 3)] it "orders by function name (ascending)" $- order [CC (11, 1, "g", 3), CC (11, 1, "f", 3)] `shouldBe`- [CC (11, 1, "f", 3), CC (11, 1, "g", 3)]- it "does not remove or add elements" $+ order [CC (lo 11, "g", 3), CC (lo 11, "f", 3)] `shouldBe`+ [CC (lo 11, "f", 3), CC (lo 11, "g", 3)]+ it "does not add or remove elements" $ property $ \xs -> sort xs == sort (order xs)- describe "parseCode" $ do+ it "is idempotent" $+ property $ \xs -> order xs == order (order xs)+ describe "filterResults" $ do+ it "discards results with too low complexity" $+ filterResults (Config { minCC = 3, outputMode = BareText })+ ("p", Right [ CC (ones, "f", 3), CC (lo 2, "g", 2)+ , CC (lo 4, "h", 10), CC (lo 3, "l", 1)])+ `shouldBe`+ ("p", Right [CC (lo 4, "h", 10), CC (ones, "f", 3)])+ it "does nothing on Left" $+ property $ \m o p err -> filterResults (Config m o)+ (p, Left err) ==+ (p, Left err)+ describe "analyze" $ do it "accounts for case" $- unlines [ "f n = case n of"- , " 2 -> 24"- , " 3 -> 27"- , " _ -> 49"] `shouldParse` Right [CC (1, 1, "f", 3)]+ "case.hs" `shouldAnalyze` Right [CC (ones, "func", 3)] it "accounts for if..then..else" $- "f n = if n == 4 then 24 else 20" `shouldParse`- Right [CC (1, 1, "f", 2)]+ "ifthenelse.hs" `shouldAnalyze` Right [CC (ones, "f", 2)]+ it "accounts for lambda case" $+ "lambdacase.hs" `shouldAnalyze` Right [CC (lo 2, "g", 3)]+ it "accounts for multi way if" $+ "multiif.hs" `shouldAnalyze` Right [CC (lo 2, "f", 4)]+ it "accounts for || operator" $+ "orop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)]+ it "accounts for && operator" $+ "andop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)]+ it "counts everything in a real example" $+ "stack-setup.hs" `shouldAnalyze`+ Right [ CC (lo 3, "ensureCompiler", 14)+ , CC ((4, 9), "wc", 1)+ , CC ((21, 9), "needLocal", 4)+ , CC ((27, 9), "isWanted", 1)+ , CC ((41, 17), "installedCompiler", 2)+ , CC ((81, 37), "tool", 1)+ , CC ((94, 17), "idents", 1)+ , CC ((103, 21), "m", 1)+ ]+ it "applies CPP when needed" $+ "cpp.hs" `shouldAnalyze` Right [CC (lo 5, "f", 4)]+ it "catches syntax errors" $+ "syntaxerror.hs" `shouldAnalyze`+ Left "2:1 parse error (possibly incorrect indentation or mismatched brackets)"+ it "catches CPP parsing errors" $+ unsafePerformIO (analyze (path "cpp-error.hs")) `shouldSatisfy`+ \(_, res) ->+ isLeft res && ("2:0 error: unterminated #else"+ `isPrefixOf` head (lefts [res]))
test/HLint.hs view
@@ -7,7 +7,6 @@ arguments = [ "app" , "src"- , "test" ] main :: IO ()