diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -25,7 +25,7 @@

Argon screenshot + src="https://cloud.githubusercontent.com/assets/238549/10644166/5a0f5efc-7827-11e5-9b29-6e7bcccb2345.png">

@@ -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" + } + ] diff --git a/USAGE.txt b/USAGE.txt --- a/USAGE.txt +++ b/USAGE.txt @@ -1,5 +1,5 @@ Usage: - argon [-h] [--no-color | --json] [-m=] ... + argon [-h] [--no-color] [--json] [-m=] ... Options: -h --help show this help diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/argon.cabal b/argon.cabal --- a/argon.cabal +++ b/argon.cabal @@ -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 diff --git a/src/Argon.hs b/src/Argon.hs --- a/src/Argon.hs +++ b/src/Argon.hs @@ -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 diff --git a/src/Argon/Formatters.hs b/src/Argon/Formatters.hs --- a/src/Argon/Formatters.hs +++ b/src/Argon/Formatters.hs @@ -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 diff --git a/src/Argon/Loc.hs b/src/Argon/Loc.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Loc.hs @@ -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 diff --git a/src/Argon/Parser.hs b/src/Argon/Parser.hs --- a/src/Argon/Parser.hs +++ b/src/Argon/Parser.hs @@ -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 ".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) diff --git a/src/Argon/Preprocess.hs b/src/Argon/Preprocess.hs new file mode 100644 --- /dev/null +++ b/src/Argon/Preprocess.hs @@ -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) } diff --git a/src/Argon/Results.hs b/src/Argon/Results.hs --- a/src/Argon/Results.hs +++ b/src/Argon/Results.hs @@ -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 diff --git a/src/Argon/Types.hs b/src/Argon/Types.hs --- a/src/Argon/Types.hs +++ b/src/Argon/Types.hs @@ -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 + ] diff --git a/src/Argon/Visitor.hs b/src/Argon/Visitor.hs --- a/src/Argon/Visitor.hs +++ b/src/Argon/Visitor.hs @@ -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, "", 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 -> "" -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,5 @@ - '.' extra-deps: - docopt-0.7.0.4 -resolver: lts-3.9 +- pathwalk-0.3.1.0 +resolver: lts-3.11 diff --git a/test/ArgonSpec.hs b/test/ArgonSpec.hs --- a/test/ArgonSpec.hs +++ b/test/ArgonSpec.hs @@ -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])) diff --git a/test/HLint.hs b/test/HLint.hs --- a/test/HLint.hs +++ b/test/HLint.hs @@ -7,7 +7,6 @@ arguments = [ "app" , "src" - , "test" ] main :: IO ()