├── test ├── tree │ ├── a.hs │ ├── a.txt │ ├── b.txt │ ├── sub │ │ ├── b.hs │ │ └── c.hs │ └── sub2 │ │ ├── a.hs │ │ └── e.hs ├── data │ ├── syntaxerror.hs │ ├── include │ │ └── necessaryInclude.h │ ├── orop.hs │ ├── andop.hs │ ├── ifthenelse.hs │ ├── missingcpp.hs │ ├── cpp-error.hs │ ├── case.hs │ ├── lambdacase.hs │ ├── missingmacros.hs │ ├── th.hs │ ├── cpp.hs │ ├── multiif.hs │ ├── missingincluded.hs │ ├── foreignimports.hs │ ├── scopedtypevariables.hs │ ├── arrows.hs │ ├── cpp-psyn.hs │ ├── test-old.cabal │ ├── test.cabal │ ├── test-other.cabal │ ├── datakinds.hs │ ├── typefamilies.hs │ ├── stack-setup.hs │ └── cabal_macros.h ├── Spec.hs ├── HLint.hs └── ArgonSpec.hs ├── Setup.hs ├── stack.yaml ├── stack-travis-coveralls.yaml ├── .gitignore ├── USAGE.txt ├── CHANGELOG.md ├── src ├── Argon │ ├── Loc.hs │ ├── Cabal.hs │ ├── Walker.hs │ ├── SYB │ │ └── Utils.hs │ ├── Formatters.hs │ ├── Preprocess.hs │ ├── Results.hs │ ├── Visitor.hs │ ├── Types.hs │ └── Parser.hs └── Argon.hs ├── LICENSE ├── app └── Main.hs ├── argon.cabal ├── .travis.yml └── README.md /test/tree/a.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/a.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/b.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/sub/b.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/sub/c.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/sub2/a.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/tree/sub2/e.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/data/syntaxerror.hs: -------------------------------------------------------------------------------- 1 | g n = 2 + 2 | -------------------------------------------------------------------------------- /test/data/include/necessaryInclude.h: -------------------------------------------------------------------------------- 1 | #define FOO 3 2 | -------------------------------------------------------------------------------- /test/data/orop.hs: -------------------------------------------------------------------------------- 1 | g n = n == 2 || n == 49 || n == 2489 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/data/andop.hs: -------------------------------------------------------------------------------- 1 | g n = n < 68 && n `mod` 3 == 2 && n > 49 2 | -------------------------------------------------------------------------------- /test/data/ifthenelse.hs: -------------------------------------------------------------------------------- 1 | f n = if n == 4 then 24 else 20 2 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.6 2 | 3 | extra-deps: [dirstream-1.0.3] 4 | 5 | -------------------------------------------------------------------------------- /test/data/missingcpp.hs: -------------------------------------------------------------------------------- 1 | #if 0 2 | f = 3 3 | #else 4 | f m n = 2 5 | #endif 6 | -------------------------------------------------------------------------------- /test/data/cpp-error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if 0 3 | f = 3 4 | #else 5 | f m n = 2 6 | -------------------------------------------------------------------------------- /test/data/case.hs: -------------------------------------------------------------------------------- 1 | func n = case n of 2 | 2 -> 3 3 | 4 -> 6 4 | _ -> 42 5 | -------------------------------------------------------------------------------- /test/data/lambdacase.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | g = \case 3 | 3 -> 4 4 | 2 -> 5 5 | _ -> 6 6 | -------------------------------------------------------------------------------- /test/data/missingmacros.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if MIN_VERSION_base(4,5,0) 3 | f a = if a == 0 then 2 else 3*a 4 | #else 5 | g = 0 6 | #endif 7 | -------------------------------------------------------------------------------- /test/data/th.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Blow where 3 | 4 | import Language.Haskell.TH 5 | 6 | foo :: Q Exp 7 | foo = [| \f -> f 2 |] 8 | -------------------------------------------------------------------------------- /stack-travis-coveralls.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | extra-deps: 6 | - stack-hpc-coveralls-0.0.0.3 7 | - docopt-0.7.0.4 8 | resolver: lts-3.11 9 | -------------------------------------------------------------------------------- /test/data/cpp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if 0 3 | f = 3 4 | #else 5 | f m n = case 2*n of 6 | 3 -> if m == 4 || m - n < 0 then 32 else 42 7 | _ -> 41 8 | #endif 9 | -------------------------------------------------------------------------------- /test/data/multiif.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | f n = if | n `mod` 34 == 0 -> 3 3 | | n `div` 24 == 1 -> 24 4 | | n + 42 - 4 == 0 -> 2424 5 | | _ -> 42 6 | -------------------------------------------------------------------------------- /test/data/missingincluded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #include "necessaryInclude.h" 3 | 4 | #ifdef FOO 5 | f n = case n of 6 | 2 -> 2424 7 | 3 -> 2 8 | _ -> 24241 9 | #else 10 | g = 42 11 | #endif 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw[eop] 2 | dist/ 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | *.tix 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | .stack-work/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | tmp/ 20 | TAGS 21 | -------------------------------------------------------------------------------- /test/data/foreignimports.hs: -------------------------------------------------------------------------------- 1 | module Internal.Sparse where 2 | 3 | import Foreign.C.Types(CInt(..)) 4 | import Foreign(Ptr) 5 | 6 | foreign import ccall unsafe "smXv" 7 | c_smXv :: SMxV 8 | 9 | foreign import ccall unsafe "smTXv" 10 | c_smTXv :: SMxV 11 | -------------------------------------------------------------------------------- /test/HLint.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Language.Haskell.HLint (hlint) 4 | import System.Exit (exitFailure, exitSuccess) 5 | 6 | arguments :: [String] 7 | arguments = 8 | [ "app" 9 | , "src" 10 | ] 11 | 12 | main :: IO () 13 | main = do 14 | hints <- hlint arguments 15 | if null hints then exitSuccess else exitFailure 16 | -------------------------------------------------------------------------------- /test/data/scopedtypevariables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Utility.Exception where 4 | 5 | import Control.Monad.Catch as X hiding (Handler) 6 | import qualified Control.Monad.Catch as M 7 | 8 | catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a 9 | catchNonAsync a onerr = a catches 10 | [ M.Handler ( (e :: SomeException) -> onerr e) 11 | ] 12 | -------------------------------------------------------------------------------- /test/data/arrows.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | 3 | -- | First argument: basis for a new "pretty" anchor if none exists yet 4 | -- Second argument: a key ("ugly" anchor) 5 | -- Returns: saved "pretty" anchor or created new one 6 | getAnchor :: OdtReaderSafe (AnchorPrefix, Anchor) Anchor 7 | getAnchor = proc (baseIdent, uglyAnchor) -> do 8 | state <- getExtraState -< () 9 | returnA -< prettyAnchor 10 | -------------------------------------------------------------------------------- /test/data/cpp-psyn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef HLINT 3 | {-# LANGUAGE ViewPatterns #-} 4 | #endif 5 | {-# LANGUAGE PatternSynonyms #-} 6 | 7 | data Counted a = Counted Int [a] deriving (Eq, Ord, Read, Show) 8 | 9 | pattern (:+) :: () => () => a -> Counted a -> Counted a 10 | pattern a :+ as <- Counted (subtract 1 -> i) (a : (Counted i -> as)) where 11 | a :+ Counted i as = Counted (i+1) (a:as) 12 | -------------------------------------------------------------------------------- /USAGE.txt: -------------------------------------------------------------------------------- 1 | Usage: 2 | argon [options] ... 3 | 4 | Options: 5 | -h --help show this help 6 | -m --min= the minimum complexity to show in results 7 | --cabal-file= path to Cabal main file 8 | --cabal-macros= Cabal header file with versions macros 9 | -I --include-dir= additional directory with header files 10 | --no-color results are not colored 11 | -j --json results are serialized to JSON 12 | -------------------------------------------------------------------------------- /test/data/test-old.cabal: -------------------------------------------------------------------------------- 1 | name: ftw 2 | version: 0.0 3 | author: Michele Lacchia 4 | build-type: Simple 5 | cabal-version: >=1.18 6 | 7 | library 8 | hs-source-dirs: . 9 | extensions: CPP 10 | build-depends: base >=4.7 && <5 11 | default-language: Haskell2010 12 | ghc-options: -Wall 13 | if impl(ghc < 7.8) 14 | buildable: False 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/rubik/argon 19 | -------------------------------------------------------------------------------- /test/data/test.cabal: -------------------------------------------------------------------------------- 1 | name: ftw 2 | version: 0.0 3 | author: Michele Lacchia 4 | build-type: Simple 5 | cabal-version: >=1.18 6 | 7 | library 8 | hs-source-dirs: . 9 | default-extensions: CPP 10 | build-depends: base >=4.7 && <5 11 | default-language: Haskell2010 12 | ghc-options: -Wall 13 | if impl(ghc < 7.8) 14 | buildable: False 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/rubik/argon 19 | -------------------------------------------------------------------------------- /test/data/test-other.cabal: -------------------------------------------------------------------------------- 1 | name: ftw 2 | version: 0.0 3 | author: Michele Lacchia 4 | build-type: Simple 5 | cabal-version: >=1.18 6 | 7 | library 8 | hs-source-dirs: . 9 | other-extensions: CPP 10 | build-depends: base >=4.7 && <5 11 | default-language: Haskell2010 12 | ghc-options: -Wall 13 | if impl(ghc < 7.8) 14 | buildable: False 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/rubik/argon 19 | -------------------------------------------------------------------------------- /test/data/datakinds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE GADTs #-} 4 | 5 | data JobDescription = JobOne 6 | | JobTwo 7 | | JobThree 8 | deriving (Show, Eq) 9 | 10 | data SJobDescription :: JobDescription -> * where 11 | SJobOne :: { jobOneN :: Int } -> SJobDescription JobOne 12 | SJobTwo :: SJobDescription JobTwo 13 | SJobThree :: { jobThreeN :: Int } -> SJobDescription JobThree 14 | 15 | taskOneWorker :: SJobDescription JobOne -> IO () 16 | taskOneWorker t = do 17 | putStrLn $ "Job: " ++ (show $ jobOneN t) 18 | 19 | main :: IO () 20 | main = taskOneWorker (SJobOne 10) 21 | -------------------------------------------------------------------------------- /test/data/typefamilies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | 10 | import Control.Lens.Lens 11 | import Data.Functor.Identity 12 | import Data.Functor.Product 13 | import Data.Proxy (Proxy (Proxy)) 14 | import GHC.Generics (Generic (..), (:*:) (..), K1 (..), M1 (..), U1 (..)) 15 | import Control.Applicative 16 | 17 | type family GSize (f :: * -> *) 18 | type instance GSize U1 = Z 19 | type instance GSize (K1 i c) = S Z 20 | type instance GSize (M1 i c f) = GSize f 21 | type instance GSize (a :*: b) = Add (GSize a) (GSize b) 22 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | This package uses [Semantic Versioning][1]. 4 | 5 | ## v0.4.0.0 6 | 7 | - Add streaming capabilities (haskell-pipes) for lower memory usage: #18. 8 | - Add `--cabal-macros` and `--include-dir` options: #17. 9 | - Add `--cabal-file` to read default extensions: #19. 10 | 11 | ## v0.3.2.0 12 | 13 | - Fix error in CPP processing: #14. 14 | - Include updated `everythingStaged` code (by @alanz): #20. 15 | 16 | ## v0.3.1.2 17 | 18 | - Add `stack-7.8.yaml` to sdist. It's then possible to run tests from sdist. 19 | 20 | ## v0.3.1.1 21 | 22 | - Add test data to sdist: fpco/stackage#932. 23 | 24 | ## v0.3.1.0 25 | 26 | - Add compatibility with GHC 7.8: #6. 27 | 28 | ## v0.3.0.0 29 | 30 | - Major: replace Haskell-Src-Exts with GHC API: #5. 31 | - Add basic tests: #7. 32 | 33 | ## v0.2.0.0 34 | 35 | - Add `USAGE.txt` to tarball: #2. 36 | 37 | ## v0.1.0.0 38 | 39 | - Initially created. 40 | 41 | [1]: http://semver.org/spec/v2.0.0.html 42 | -------------------------------------------------------------------------------- /src/Argon/Loc.hs: -------------------------------------------------------------------------------- 1 | module Argon.Loc (Loc, srcSpanToLoc, locToString, tagMsg) 2 | where 3 | 4 | import Text.Printf (printf) 5 | import Control.Arrow ((&&&)) 6 | 7 | import qualified SrcLoc as GHC 8 | import qualified FastString as GHC 9 | 10 | -- | Type synonym representing a location in the source code. The tuple 11 | -- represents the following: @(start line, start col)@. 12 | type Loc = (Int, Int) 13 | 14 | 15 | -- | Convert a GHC's 'SrcSpan' to a @(line, column)@ pair. In case of a GHC's 16 | -- "bad span" the resulting pair is @(0, 0)@. 17 | srcSpanToLoc :: GHC.SrcSpan -> Loc 18 | srcSpanToLoc ss = lloc $ GHC.srcSpanStart ss 19 | where lloc = (GHC.srcLocLine &&& GHC.srcLocCol) . toRealSrcLoc 20 | toRealSrcLoc (GHC.RealSrcLoc z) = z 21 | toRealSrcLoc _ = GHC.mkRealSrcLoc (GHC.mkFastString "no info") 0 0 22 | 23 | -- | Convert a location to a string of the form "line:col" 24 | locToString :: Loc -> String 25 | locToString = uncurry $ printf "%d:%d" 26 | 27 | -- | Add the location to a string message 28 | tagMsg :: Loc -> String -> String 29 | tagMsg s msg = locToString s ++ " " ++ msg 30 | -------------------------------------------------------------------------------- /src/Argon.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Argon 3 | -- Copyright: (c) 2015 Michele Lacchia 4 | -- License: ISC 5 | -- Maintainer: Michele Lacchia 6 | -- Stability: alpha 7 | -- Portability: portable 8 | -- 9 | -- Programmatic interface to Argon. 10 | module Argon 11 | ( 12 | -- * Types 13 | AnalysisResult 14 | , ComplexityBlock(CC) 15 | , OutputMode(..) 16 | , Config(..) 17 | , defaultConfig 18 | , Loc 19 | , LModule 20 | -- * Gathering source files 21 | , allFiles 22 | -- * Parsing 23 | , analyze 24 | , parseModule 25 | , parseExts 26 | -- * Manipulating results 27 | , order 28 | , filterResults 29 | , filterNulls 30 | , exportStream 31 | -- * Formatting results 32 | , bareTextFormatter 33 | , coloredTextFormatter 34 | -- * Utilities 35 | , srcSpanToLoc 36 | , locToString 37 | , tagMsg 38 | ) where 39 | 40 | import Argon.Parser (LModule, analyze, parseModule) 41 | import Argon.Results (order, filterResults, filterNulls, exportStream) 42 | import Argon.Cabal (parseExts) 43 | import Argon.Types 44 | import Argon.Loc 45 | import Argon.Walker (allFiles) 46 | import Argon.Formatters (bareTextFormatter, coloredTextFormatter) 47 | -------------------------------------------------------------------------------- /src/Argon/Cabal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Argon.Cabal (parseExts) 3 | where 4 | 5 | import Data.List (nub) 6 | #if __GLASGOW_HASKELL__ < 710 7 | import Control.Applicative ((<$>)) 8 | #endif 9 | 10 | import qualified Distribution.PackageDescription as Dist 11 | import qualified Distribution.PackageDescription.Parse as Dist 12 | import qualified Distribution.Verbosity as Dist 13 | import qualified Language.Haskell.Extension as Dist 14 | 15 | 16 | -- | Parse the given Cabal file generate a list of GHC extension flags. The 17 | -- extension names are read from the default-extensions field in the library 18 | -- section. 19 | parseExts :: FilePath -> IO [String] 20 | #if __GLASGOW_HASKELL__ < 802 21 | parseExts path = extract <$> Dist.readPackageDescription Dist.silent path 22 | #else 23 | parseExts path = extract <$> Dist.readGenericPackageDescription Dist.silent path 24 | #endif 25 | where extract pkg = maybe [] extFromBI $ 26 | Dist.libBuildInfo . Dist.condTreeData <$> Dist.condLibrary pkg 27 | 28 | extFromBI :: Dist.BuildInfo -> [String] 29 | extFromBI binfo = map toString . nub $ allExts 30 | where toString (Dist.UnknownExtension ext) = ext 31 | toString (Dist.EnableExtension ext) = show ext 32 | toString (Dist.DisableExtension ext) = show ext 33 | allExts = concatMap ($ binfo) 34 | [Dist.defaultExtensions, Dist.otherExtensions, Dist.oldExtensions] 35 | -------------------------------------------------------------------------------- /src/Argon/Walker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Argon.Walker (allFiles) 3 | where 4 | 5 | import Data.DirStream (childOf) 6 | import Data.List (isSuffixOf) 7 | import Filesystem.Path.CurrentOS (decodeString, encodeString) 8 | import Pipes (ListT, MonadIO, Producer, each, 9 | every, liftIO, (>->)) 10 | import qualified Pipes.Prelude as P 11 | import Pipes.Safe 12 | import System.Directory (doesDirectoryExist, doesFileExist, 13 | pathIsSymbolicLink) 14 | import System.FilePath (takeExtension) 15 | 16 | -- | Starting from a path, generate a sequence of paths corresponding 17 | -- to Haskell files. The filesystem is traversed depth-first. 18 | allFiles :: (MonadIO m, MonadSafe m) => FilePath -> Producer FilePath m () 19 | allFiles path = do 20 | isFile <- liftIO $ doesFileExist path 21 | if isFile then each [path] >-> P.filter (".hs" `isSuffixOf`) 22 | else every $ hsFilesIn path 23 | 24 | -- | List the regular files in a directory. 25 | hsFilesIn :: MonadSafe m => FilePath -> ListT m FilePath 26 | hsFilesIn path = do 27 | child <- encodeString <$> childOf (decodeString path) 28 | isDir <- liftIO $ doesDirectoryExist child 29 | isSymLink <- liftIO $ pathIsSymbolicLink child 30 | if isDir && not isSymLink 31 | then hsFilesIn child 32 | else if not isSymLink && takeExtension child == ".hs" 33 | then return child 34 | else mempty 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Michele Lacchia (c) 2015 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Michele Lacchia nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module Main where 4 | 5 | import Pipes 6 | import Pipes.Safe (runSafeT) 7 | import qualified Pipes.Prelude as P 8 | import Control.Monad (forM_) 9 | import System.Environment (getArgs) 10 | import System.Console.Docopt 11 | 12 | import Argon 13 | 14 | 15 | patterns :: Docopt 16 | patterns = [docoptFile|USAGE.txt|] 17 | 18 | getArgOrExit :: Arguments -> Option -> IO String 19 | getArgOrExit = getArgOrExitWith patterns 20 | 21 | getOpt :: Arguments -> String -> String -> String 22 | getOpt args def opt = getArgWithDefault args def $ longOption opt 23 | 24 | readConfig :: Arguments -> IO Config 25 | readConfig args = do 26 | xFlags <- maybe (return []) parseExts $ getArg args $ longOption "cabal-file" 27 | return Config { 28 | minCC = read $ getOpt args "1" "min" 29 | , exts = xFlags 30 | , headers = args `getAllArgs` longOption "cabal-macros" 31 | , includeDirs = args `getAllArgs` longOption "include-dir" 32 | , outputMode = if args `isPresent` longOption "json" 33 | then JSON 34 | else if args `isPresent` longOption "no-color" 35 | then BareText 36 | else Colored 37 | } 38 | 39 | main :: IO () 40 | main = do 41 | args <- parseArgsOrExit patterns =<< getArgs 42 | let ins = args `getAllArgs` argument "paths" 43 | conf <- readConfig args 44 | forM_ ins $ \path -> do 45 | let source = allFiles path 46 | >-> P.mapM (liftIO . analyze conf) 47 | >-> P.map (filterResults conf) 48 | >-> P.filter filterNulls 49 | runSafeT $ runEffect $ exportStream conf source 50 | -------------------------------------------------------------------------------- /src/Argon/SYB/Utils.hs: -------------------------------------------------------------------------------- 1 | -- The following code is temporarily taken from @alanz's fork of 2 | -- nominolo/ghc-syb. Argon will use the original ghc-syb when a new version 3 | -- is released on Hackage with @alanz's fixes. 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | module Argon.SYB.Utils (Stage(..), everythingStaged) 7 | where 8 | 9 | import GHC 10 | import NameSet (NameSet) 11 | import Data.Generics 12 | #if __GLASGOW_HASKELL__ <= 708 13 | import Coercion 14 | #endif 15 | 16 | 17 | -- | Ghc Ast types tend to have undefined holes, to be filled 18 | -- by later compiler phases. We tag Asts with their source, 19 | -- so that we can avoid such holes based on who generated the Asts. 20 | data Stage = Parser | Renamer | TypeChecker deriving (Eq, Ord, Show) 21 | 22 | -- | Like 'everything', but avoid known potholes, based on the 'Stage' that 23 | -- generated the Ast. 24 | everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r 25 | everythingStaged stage k z f x 26 | | (const False 27 | #if __GLASGOW_HASKELL__ <= 708 28 | `extQ` postTcType 29 | `extQ` nameList 30 | `extQ` coercion 31 | `extQ` cmdTable 32 | #endif 33 | `extQ` fixity `extQ` nameSet) x = z 34 | | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x) 35 | where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool 36 | #if __GLASGOW_HASKELL__ <= 708 37 | postTcType = const (stage < TypeChecker) :: PostTcType -> Bool 38 | nameList = const (stage < TypeChecker) :: [Name] -> Bool 39 | coercion = const (stage < TypeChecker) :: Coercion -> Bool 40 | cmdTable = const (stage < TypeChecker) :: CmdSyntaxTable RdrName -> Bool 41 | #endif 42 | fixity = const (stage < Renamer) :: GHC.Fixity -> Bool 43 | -------------------------------------------------------------------------------- /src/Argon/Formatters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | module Argon.Formatters (bareTextFormatter, coloredTextFormatter) 3 | where 4 | 5 | import Text.Printf (printf) 6 | import System.Console.ANSI 7 | 8 | import Pipes 9 | import qualified Pipes.Prelude as P 10 | 11 | import Argon.Types 12 | import Argon.Loc 13 | 14 | 15 | bareTextFormatter :: MonadIO m => Pipe (FilePath, AnalysisResult) String m () 16 | bareTextFormatter = formatResult 17 | id 18 | ("\terror: " ++) 19 | (\(CC (l, func, cc)) -> printf "\t%s %s - %d" (locToString l) func cc) 20 | 21 | coloredTextFormatter :: MonadIO m => Pipe (FilePath, AnalysisResult) String m () 22 | coloredTextFormatter = formatResult 23 | (\name -> bold ++ name ++ reset) 24 | (printf "\t%serror%s: %s" (fore Red) reset) 25 | (\(CC (l, func, cc)) -> printf "\t%s %s - %s" (locToString l) 26 | (coloredFunc func l) 27 | (coloredRank cc)) 28 | 29 | -- | ANSI bold color 30 | bold :: String 31 | bold = setSGRCode [SetConsoleIntensity BoldIntensity] 32 | 33 | -- | Make a ANSI foreground color sequence 34 | fore :: Color -> String 35 | fore color = setSGRCode [SetColor Foreground Dull color] 36 | 37 | -- | ANSI sequence for reset 38 | reset :: String 39 | reset = setSGRCode [] 40 | 41 | coloredFunc :: String -> Loc -> String 42 | coloredFunc f (_, c) = fore color ++ f ++ reset 43 | where color = if c == 1 then Cyan else Magenta 44 | 45 | coloredRank :: Int -> String 46 | coloredRank c = printf "%s%s (%d)%s" (fore color) rank c reset 47 | where (color, rank) 48 | | c <= 5 = (Green, "A") 49 | | c <= 10 = (Yellow, "B") 50 | | otherwise = (Red, "C") 51 | 52 | formatResult :: (MonadIO m) 53 | => (String -> String) -- ^ The header formatter 54 | -> (String -> String) -- ^ The error formatter 55 | -> (ComplexityBlock -> String) -- ^ The single line formatter 56 | -> Pipe (FilePath, AnalysisResult) String m () 57 | formatResult header errorF singleF = for cat $ \case 58 | (path, Left err) -> do 59 | yield $ header path 60 | yield $ errorF err 61 | (path, Right rs) -> do 62 | yield $ header path 63 | each rs >-> P.map singleF 64 | -------------------------------------------------------------------------------- /src/Argon/Preprocess.hs: -------------------------------------------------------------------------------- 1 | -- The following code is taken and modified from ghc-exactprint, because adding 2 | -- a dependency for just one module and then adding wrappers for that module 3 | -- seemed excessive. 4 | {-# LANGUAGE CPP #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | -- | This module provides support for CPP and interpreter directives. 7 | module Argon.Preprocess 8 | ( 9 | CppOptions(..) 10 | , defaultCppOptions 11 | , getPreprocessedSrcDirect 12 | ) where 13 | 14 | #if __GLASGOW_HASKELL__ < 710 15 | import Control.Applicative ((<$>)) 16 | #endif 17 | import qualified GHC 18 | import qualified DynFlags as GHC 19 | import qualified MonadUtils as GHC 20 | import qualified DriverPhases as GHC 21 | import qualified DriverPipeline as GHC 22 | import qualified HscTypes as GHC 23 | 24 | data CppOptions = CppOptions 25 | { cppDefine :: [String] -- ^ CPP #define macros 26 | , cppInclude :: [FilePath] -- ^ CPP Includes directory 27 | , cppFile :: [FilePath] -- ^ CPP pre-include file 28 | } 29 | 30 | 31 | defaultCppOptions :: CppOptions 32 | defaultCppOptions = CppOptions [] [] [] 33 | 34 | getPreprocessedSrcDirect :: (GHC.GhcMonad m) 35 | => CppOptions 36 | -> FilePath 37 | -> m (String, GHC.DynFlags) 38 | getPreprocessedSrcDirect cppOptions file = do 39 | hscEnv <- GHC.getSession 40 | let dfs = GHC.hsc_dflags hscEnv 41 | newEnv = hscEnv { GHC.hsc_dflags = injectCppOptions cppOptions dfs } 42 | (dflags', hspp_fn) <- 43 | GHC.liftIO $ GHC.preprocess newEnv (file, Just (GHC.Cpp GHC.HsSrcFile)) 44 | txt <- GHC.liftIO $ readFile hspp_fn 45 | return (txt, dflags') 46 | 47 | injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags 48 | injectCppOptions CppOptions{..} dflags = 49 | foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude 50 | ++ map mkInclude cppFile) 51 | where 52 | mkDefine = ("-D" ++) 53 | mkIncludeDir = ("-I" ++) 54 | mkInclude = ("-include" ++) 55 | 56 | addOptP :: String -> GHC.DynFlags -> GHC.DynFlags 57 | addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s}) 58 | 59 | alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags 60 | alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) } 61 | -------------------------------------------------------------------------------- /src/Argon/Results.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Argon.Results (order, filterResults, filterNulls, exportStream) 4 | where 5 | 6 | import Data.Ord (comparing) 7 | import Data.List (sortBy) 8 | import Data.String (IsString) 9 | #if __GLASGOW_HASKELL__ < 710 10 | import Control.Applicative ((<*), (*>)) 11 | #endif 12 | 13 | import Data.Aeson (encode) 14 | import Pipes 15 | import Pipes.Group 16 | import qualified Pipes.Prelude as P 17 | import qualified Pipes.ByteString as PB 18 | import Lens.Simple ((^.)) 19 | 20 | import Argon.Formatters 21 | import Argon.Types 22 | 23 | 24 | -- sortOn is built-in only in base 4.8.0.0 onwards 25 | sortOn :: Ord b => (a -> b) -> [a] -> [a] 26 | sortOn f = 27 | map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) 28 | 29 | -- | Order a list of blocks. Ordering is done with respect to: 30 | -- 31 | -- 1. complexity (descending) 32 | -- 2. line number (ascending) 33 | -- 3. function name (alphabetically) 34 | order :: [ComplexityBlock] -> [ComplexityBlock] 35 | order = sortOn (\(CC ((l, _), f, cc)) -> (-cc, l, f)) 36 | 37 | -- | A result is discarded if it correspond to a successful analysis and there 38 | -- are no blocks to show 39 | filterNulls :: (FilePath, AnalysisResult) -> Bool 40 | filterNulls (_, r) = case r of 41 | Left _ -> True 42 | Right [] -> False 43 | _ -> True 44 | 45 | -- | Filter the results of the analysis, with respect to the given 46 | -- 'Config'. 47 | filterResults :: Config 48 | -> (FilePath, AnalysisResult) 49 | -> (FilePath, AnalysisResult) 50 | filterResults _ (s, Left err) = (s, Left err) 51 | filterResults o (s, Right rs) = 52 | (s, Right $ order [r | r@(CC (_, _, cc)) <- rs, cc >= minCC o]) 53 | 54 | -- | Export analysis' results. How to export the data is defined by the 55 | -- 'Config' parameter. 56 | exportStream :: (MonadIO m) 57 | => Config 58 | -> Producer (FilePath, AnalysisResult) m () 59 | -> Effect m () 60 | exportStream conf source = 61 | case outputMode conf of 62 | BareText -> source >-> bareTextFormatter >-> P.stdoutLn 63 | Colored -> source >-> coloredTextFormatter >-> P.stdoutLn 64 | JSON -> jsonStream (source >-> P.map encode) 65 | >-> for cat (\i -> PB.fromLazy i >-> PB.stdout) 66 | 67 | jsonStream :: (MonadIO m) 68 | => IsString a 69 | => Producer a m () 70 | -> Producer a m () 71 | jsonStream source = yield "[" *> intersperse' "," source <* yield "]\n" 72 | 73 | intersperse' :: Monad m => a -> Producer a m r -> Producer a m r 74 | intersperse' a producer = intercalates (yield a) (producer ^. chunksOf 1) 75 | -------------------------------------------------------------------------------- /src/Argon/Visitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Argon.Visitor (funcsCC) 3 | where 4 | 5 | import Argon.SYB.Utils (Stage (..), everythingStaged) 6 | import Control.Arrow ((&&&)) 7 | import Data.Generics (Data, mkQ) 8 | 9 | import qualified GHC 10 | import qualified OccName as GHC 11 | import qualified RdrName as GHC 12 | 13 | import Argon.Loc 14 | import Argon.Types (ComplexityBlock (..)) 15 | 16 | type Exp = GHC.HsExpr GHC.RdrName 17 | type Function = GHC.HsBindLR GHC.RdrName GHC.RdrName 18 | type MatchBody = GHC.LHsExpr GHC.RdrName 19 | 20 | 21 | -- | Compute cyclomatic complexity of every function binding in the given AST. 22 | funcsCC :: (Data from) => from -> [ComplexityBlock] 23 | funcsCC = map funCC . getBinds 24 | 25 | funCC :: Function -> ComplexityBlock 26 | funCC f = CC (getLocation $ GHC.fun_id f, getFuncName f, complexity f) 27 | 28 | getBinds :: (Data from) => from -> [Function] 29 | getBinds = everythingStaged Parser (++) [] $ mkQ [] visit 30 | where visit fun@GHC.FunBind {} = [fun] 31 | visit _ = [] 32 | 33 | getLocation :: GHC.Located a -> Loc 34 | getLocation = srcSpanToLoc . GHC.getLoc 35 | 36 | getFuncName :: Function -> String 37 | getFuncName = getName . GHC.unLoc . GHC.fun_id 38 | 39 | complexity :: Function -> Int 40 | complexity f = let matches = getMatches f 41 | query = everythingStaged Parser (+) 0 $ 0 `mkQ` visit 42 | visit = uncurry (+) . (visitExp &&& visitOp) 43 | in length matches + sumWith getGRHSsFromMatch matches + sumWith query matches 44 | 45 | getMatches :: Function -> [GHC.LMatch GHC.RdrName MatchBody] 46 | getMatches = GHC.unLoc . GHC.mg_alts . GHC.fun_matches 47 | 48 | getGRHSsFromMatch :: GHC.LMatch GHC.RdrName MatchBody -> Int 49 | getGRHSsFromMatch match = length (getGRHSs' match) - 1 50 | where 51 | getGRHSs' :: GHC.LMatch GHC.RdrName MatchBody -> [GHC.LGRHS GHC.RdrName MatchBody] 52 | getGRHSs' = GHC.grhssGRHSs . GHC.m_grhss . GHC.unLoc 53 | 54 | getName :: GHC.RdrName -> String 55 | getName = GHC.occNameString . GHC.rdrNameOcc 56 | 57 | sumWith :: (a -> Int) -> [a] -> Int 58 | sumWith f = sum . map f 59 | 60 | visitExp :: Exp -> Int 61 | visitExp GHC.HsIf {} = 1 62 | visitExp (GHC.HsMultiIf _ alts) = length alts - 1 63 | #if __GLASGOW_HASKELL__ < 802 64 | visitExp (GHC.HsCase _ alts) = length (GHC.unLoc . GHC.mg_alts $ alts) - 1 65 | visitExp (GHC.HsLamCase _ alts) = length (GHC.unLoc . GHC.mg_alts $ alts) - 1 66 | #else 67 | visitExp (GHC.HsLamCase mg) = length (GHC.unLoc . GHC.mg_alts $ mg) - 1 68 | visitExp (GHC.HsCase _ mg) = length (GHC.unLoc . GHC.mg_alts $ mg) - 1 69 | #endif 70 | visitExp _ = 0 71 | 72 | visitOp :: Exp -> Int 73 | visitOp (GHC.OpApp _ (GHC.L _ (GHC.HsVar op)) _ _) = 74 | case getName (GHC.unLoc op) of 75 | "||" -> 1 76 | "&&" -> 1 77 | _ -> 0 78 | visitOp _ = 0 79 | -------------------------------------------------------------------------------- /src/Argon/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | #if __GLASGOW_HASKELL__ < 710 6 | {-# LANGUAGE DeriveDataTypeable #-} 7 | #endif 8 | 9 | module Argon.Types (ComplexityBlock(CC), AnalysisResult, Config(..) 10 | , OutputMode(..), GhcParseError(..), defaultConfig) 11 | where 12 | 13 | import Data.List (intercalate) 14 | import Data.Aeson 15 | import Data.Typeable 16 | import Control.Exception (Exception) 17 | 18 | import Argon.Loc 19 | 20 | 21 | data GhcParseError = GhcParseError { 22 | loc :: Loc 23 | , msg :: String 24 | } deriving (Typeable) 25 | 26 | -- | Hold the data associated to a function binding: 27 | -- @(location, function name, complexity)@. 28 | newtype ComplexityBlock = CC (Loc, String, Int) 29 | deriving (Show, Eq, Ord) 30 | 31 | -- | Represent the result of the analysis of one file. 32 | -- It can either be an error message or a list of 33 | -- 'ComplexityBlock's. 34 | type AnalysisResult = Either String [ComplexityBlock] 35 | 36 | -- | Type holding all the options passed from the command line. 37 | data Config = Config { 38 | -- | Minimum complexity a block has to have to be shown in results. 39 | minCC :: Int 40 | -- | Extension to activate 41 | , exts :: [String] 42 | -- | Header files to be automatically included before preprocessing 43 | , headers :: [FilePath] 44 | -- | Additional include directories for the C preprocessor 45 | , includeDirs :: [FilePath] 46 | -- | Describe how the results should be exported. 47 | , outputMode :: OutputMode 48 | } 49 | 50 | -- | Type describing how the results should be exported. 51 | data OutputMode = BareText -- ^ Text-only output, no colors. 52 | | Colored -- ^ Text-only output, with colors. 53 | | JSON -- ^ Data is serialized to JSON. 54 | deriving (Show, Eq) 55 | 56 | -- | Default configuration options. 57 | -- 58 | -- __Warning__: These are not Argon's default options. 59 | defaultConfig :: Config 60 | defaultConfig = Config { minCC = 1 61 | , exts = [] 62 | , headers = [] 63 | , includeDirs = [] 64 | , outputMode = JSON 65 | } 66 | 67 | instance Exception GhcParseError 68 | 69 | instance Show GhcParseError where 70 | show e = tagMsg (loc e) $ fixNewlines (msg e) 71 | where fixNewlines = intercalate "\n\t\t" . lines 72 | 73 | instance ToJSON ComplexityBlock where 74 | toJSON (CC ((s, c), func, cc)) = 75 | object [ "lineno" .= s 76 | , "col" .= c 77 | , "name" .= func 78 | , "complexity" .= cc 79 | ] 80 | 81 | instance {-# OVERLAPPING #-} ToJSON (FilePath, AnalysisResult) where 82 | toJSON (p, Left err) = object [ "path" .= p 83 | , "type" .= ("error" :: String) 84 | , "message" .= err 85 | ] 86 | toJSON (p, Right rs) = object [ "path" .= p 87 | , "type" .= ("result" :: String) 88 | , "blocks" .= rs 89 | ] 90 | -------------------------------------------------------------------------------- /src/Argon/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Argon.Parser (LModule, analyze, parseModule) 3 | where 4 | 5 | import Control.Monad (void) 6 | import qualified Control.Exception as E 7 | 8 | import qualified GHC hiding (parseModule) 9 | import qualified SrcLoc as GHC 10 | import qualified Lexer as GHC 11 | import qualified Parser as GHC 12 | import qualified DynFlags as GHC 13 | import qualified GHC.LanguageExtensions as GHC 14 | import qualified HeaderInfo as GHC 15 | import qualified MonadUtils as GHC 16 | import qualified Outputable as GHC 17 | import qualified FastString as GHC 18 | import qualified StringBuffer as GHC 19 | import GHC.Paths (libdir) 20 | 21 | import Argon.Preprocess 22 | import Argon.Visitor (funcsCC) 23 | import Argon.Types 24 | import Argon.Loc 25 | 26 | -- | Type synonym for a syntax node representing a module tagged with a 27 | -- 'SrcSpan' 28 | type LModule = GHC.Located (GHC.HsModule GHC.RdrName) 29 | 30 | 31 | -- | Parse the code in the given filename and compute cyclomatic complexity for 32 | -- every function binding. 33 | analyze :: Config -- ^ Configuration options 34 | -> FilePath -- ^ The filename corresponding to the source code 35 | -> IO (FilePath, AnalysisResult) 36 | analyze conf file = do 37 | parseResult <- (do 38 | result <- parseModule conf file 39 | E.evaluate result) `E.catch` handleExc 40 | let analysis = case parseResult of 41 | Left err -> Left err 42 | Right ast -> Right $ funcsCC ast 43 | return (file, analysis) 44 | 45 | handleExc :: E.SomeException -> IO (Either String LModule) 46 | handleExc = return . Left . show 47 | 48 | -- | Parse a module with the default instructions for the C pre-processor 49 | -- Only the includes directory is taken from the config 50 | parseModule :: Config -> FilePath -> IO (Either String LModule) 51 | parseModule conf = parseModuleWithCpp conf $ 52 | defaultCppOptions { cppInclude = includeDirs conf 53 | , cppFile = headers conf 54 | } 55 | 56 | -- | Parse a module with specific instructions for the C pre-processor. 57 | parseModuleWithCpp :: Config 58 | -> CppOptions 59 | -> FilePath 60 | -> IO (Either String LModule) 61 | parseModuleWithCpp conf cppOptions file = 62 | GHC.runGhc (Just libdir) $ do 63 | dflags <- initDynFlags conf file 64 | let useCpp = GHC.xopt GHC.Cpp dflags 65 | (fileContents, dflags1) <- 66 | if useCpp 67 | then getPreprocessedSrcDirect cppOptions file 68 | else do 69 | contents <- GHC.liftIO $ readFile file 70 | return (contents, dflags) 71 | return $ 72 | case parseCode dflags1 file fileContents of 73 | GHC.PFailed ss m -> Left $ tagMsg (srcSpanToLoc ss) 74 | (GHC.showSDoc dflags m) 75 | GHC.POk _ pmod -> Right pmod 76 | 77 | parseCode :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult LModule 78 | parseCode = runParser GHC.parseModule 79 | 80 | runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a 81 | runParser parser flags filename str = GHC.unP parser parseState 82 | where location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 83 | buffer = GHC.stringToStringBuffer str 84 | parseState = GHC.mkPState flags buffer location 85 | 86 | initDynFlags :: GHC.GhcMonad m => Config -> FilePath -> m GHC.DynFlags 87 | initDynFlags conf file = do 88 | dflags0 <- GHC.getSessionDynFlags 89 | (dflags1,_,_) <- GHC.parseDynamicFlagsCmdLine dflags0 90 | [GHC.L GHC.noSrcSpan ("-X" ++ e) | e <- exts conf] 91 | src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags1 file 92 | (dflags2, _, _) <- GHC.parseDynamicFilePragma dflags1 src_opts 93 | let dflags3 = dflags2 { GHC.log_action = customLogAction } 94 | void $ GHC.setSessionDynFlags dflags3 95 | return dflags3 96 | 97 | customLogAction :: GHC.LogAction 98 | customLogAction dflags _ severity srcSpan _ m = 99 | case severity of 100 | GHC.SevFatal -> throwError 101 | GHC.SevError -> throwError 102 | _ -> return () 103 | where throwError = E.throwIO $ GhcParseError (srcSpanToLoc srcSpan) 104 | (GHC.showSDoc dflags m) 105 | -------------------------------------------------------------------------------- /argon.cabal: -------------------------------------------------------------------------------- 1 | name: argon 2 | version: 0.4.1.0 3 | synopsis: Measure your code's complexity 4 | homepage: http://github.com/rubik/argon 5 | bug-reports: http://github.com/rubik/argon/issues 6 | license: ISC 7 | license-file: LICENSE 8 | author: Michele Lacchia 9 | maintainer: michelelacchia@gmail.com 10 | copyright: 2015 Michele Lacchia 11 | category: Development, Static Analysis 12 | build-type: Simple 13 | cabal-version: >=1.18 14 | description: 15 | Argon performs static analysis on your code in order to compute cyclomatic 16 | complexity. It is a quantitative measure of the number of linearly 17 | indipendent paths through the code. 18 | . 19 | The intended usage is through Argon's executable, which accepts a list of 20 | files or directories to analyze. The data can be optionally exported to 21 | JSON. 22 | extra-source-files: 23 | stack.yaml 24 | README.md 25 | CHANGELOG.md 26 | USAGE.txt 27 | test/data/*.hs 28 | test/data/*.h 29 | test/data/*.cabal 30 | test/data/include/*.h 31 | test/tree/*.hs 32 | test/tree/*.txt 33 | test/tree/sub/*.hs 34 | test/tree/sub2/*.hs 35 | tested-with: GHC >= 8.0.2 && < 9 36 | 37 | library 38 | hs-source-dirs: src 39 | exposed-modules: Argon 40 | other-modules: Argon.Parser 41 | Argon.Visitor 42 | Argon.Results 43 | Argon.Formatters 44 | Argon.Types 45 | Argon.Preprocess 46 | Argon.Loc 47 | Argon.Cabal 48 | Argon.SYB.Utils 49 | Argon.Walker 50 | build-depends: base >=4.7 && <5 51 | , ansi-terminal 52 | , aeson 53 | , bytestring 54 | , pipes 55 | , pipes-group 56 | , pipes-safe 57 | , pipes-bytestring 58 | , lens-simple 59 | , ghc 60 | , ghc-boot 61 | , ghc-paths 62 | , ghc-syb-utils 63 | , syb 64 | , Cabal 65 | , containers 66 | , directory 67 | , system-filepath 68 | , dirstream 69 | , filepath 70 | default-language: Haskell2010 71 | ghc-options: -Wall 72 | -Wcompat 73 | -Wincomplete-record-updates 74 | -Wincomplete-uni-patterns 75 | -Wredundant-constraints 76 | if impl(ghc < 7.8) 77 | buildable: False 78 | 79 | executable argon 80 | hs-source-dirs: app 81 | main-is: Main.hs 82 | ghc-options: -Wall 83 | build-depends: base >=4.7 && <5 84 | , argon -any 85 | , docopt >=0.7 86 | , pipes >=4.1 87 | , pipes-safe >=2.2 88 | default-language: Haskell2010 89 | if impl(ghc < 7.8) 90 | buildable: False 91 | 92 | test-suite argon-test 93 | type: exitcode-stdio-1.0 94 | hs-source-dirs: test 95 | main-is: Spec.hs 96 | other-modules: ArgonSpec 97 | build-depends: base >=4.7 && <5 98 | , argon 99 | , ansi-terminal 100 | , ghc 101 | , aeson 102 | , hspec 103 | , QuickCheck 104 | , filepath 105 | , pipes 106 | , pipes-safe 107 | ghc-options: -Wall 108 | -threaded -rtsopts -with-rtsopts=-N 109 | 110 | default-language: Haskell2010 111 | if impl(ghc < 7.8) 112 | buildable: False 113 | 114 | test-suite style 115 | type: exitcode-stdio-1.0 116 | hs-source-dirs: test 117 | main-is: HLint.hs 118 | build-depends: base 119 | , hlint 120 | default-language: Haskell2010 121 | ghc-options: -Wall 122 | 123 | source-repository head 124 | type: git 125 | location: https://github.com/rubik/argon 126 | -------------------------------------------------------------------------------- /test/data/stack-setup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -- Real example taken from Stack's source code (Setup.hs) 3 | ensureCompiler sopts = do 4 | let wc = whichCompiler (soptsWantedCompiler sopts) 5 | when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do 6 | $logWarn "stack will almost certainly fail with GHC below version 7.8" 7 | $logWarn "Valiantly attempting to run anyway, but I know this is doomed" 8 | $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" 9 | $logWarn "" 10 | 11 | -- Check the available GHCs 12 | menv0 <- getMinimalEnvOverride 13 | 14 | msystem <- 15 | if soptsUseSystem sopts 16 | then getSystemCompiler menv0 wc 17 | else return Nothing 18 | 19 | Platform expectedArch _ <- asks getPlatform 20 | 21 | let needLocal = case msystem of 22 | Nothing -> True 23 | Just _ | soptsSkipGhcCheck sopts -> False 24 | Just (system, arch) -> 25 | not (isWanted system) || 26 | arch /= expectedArch 27 | isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) 28 | 29 | -- If we need to install a GHC, try to do so 30 | mtools <- if needLocal 31 | then do 32 | getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager) 33 | 34 | localPrograms <- asks $ configLocalPrograms . getConfig 35 | installed <- listInstalled localPrograms 36 | 37 | -- Install GHC 38 | ghcVariant <- asks getGHCVariant 39 | config <- asks getConfig 40 | ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) 41 | let installedCompiler = 42 | case wc of 43 | Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion) 44 | Ghcjs -> getInstalledGhcjs installed isWanted 45 | compilerTool <- case installedCompiler of 46 | Just tool -> return tool 47 | Nothing 48 | | soptsInstallIfMissing sopts -> do 49 | si <- getSetupInfo' 50 | downloadAndInstallCompiler 51 | si 52 | (soptsWantedCompiler sopts) 53 | (soptsCompilerCheck sopts) 54 | (soptsGHCBindistURL sopts) 55 | | otherwise -> do 56 | throwM $ CompilerVersionMismatch 57 | msystem 58 | (soptsWantedCompiler sopts, expectedArch) 59 | ghcVariant 60 | (soptsCompilerCheck sopts) 61 | (soptsStackYaml sopts) 62 | (fromMaybe 63 | ("Try running \"stack setup\" to install the correct GHC into " 64 | <> T.pack (toFilePath (configLocalPrograms config))) 65 | $ soptsResolveMissingGHC sopts) 66 | 67 | -- Install msys2 on windows, if necessary 68 | platform <- asks getPlatform 69 | mmsys2Tool <- case platform of 70 | Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> 71 | case getInstalledTool installed $(mkPackageName "msys2") (const True) of 72 | Just tool -> return (Just tool) 73 | Nothing 74 | | soptsInstallIfMissing sopts -> do 75 | si <- getSetupInfo' 76 | osKey <- getOSKey platform 77 | VersionedDownloadInfo version info <- 78 | case Map.lookup osKey $ siMsys2 si of 79 | Just x -> return x 80 | Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey 81 | let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version) 82 | Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey) 83 | | otherwise -> do 84 | $logWarn "Continuing despite missing tool: msys2" 85 | return Nothing 86 | _ -> return Nothing 87 | 88 | return $ Just (compilerTool, mmsys2Tool) 89 | else return Nothing 90 | 91 | mpaths <- case mtools of 92 | Nothing -> return Nothing 93 | Just (compilerTool, mmsys2Tool) -> do 94 | let idents = catMaybes [Just compilerTool, mmsys2Tool] 95 | paths <- mapM extraDirs idents 96 | return $ Just $ mconcat paths 97 | 98 | menv <- 99 | case mpaths of 100 | Nothing -> return menv0 101 | Just ed -> do 102 | config <- asks getConfig 103 | let m = augmentPathMap (edBins ed) (unEnvOverride menv0) 104 | mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) 105 | 106 | when (soptsUpgradeCabal sopts) $ do 107 | unless needLocal $ do 108 | $logWarn "Trying to upgrade Cabal library on a GHC not installed by stack." 109 | $logWarn "This may fail, caveat emptor!" 110 | upgradeCabal menv wc 111 | 112 | case mtools of 113 | Just (ToolGhcjs cv, _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts) 114 | _ -> return () 115 | 116 | when (soptsSanityCheck sopts) $ sanityCheck menv wc 117 | 118 | return mpaths 119 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Do not choose a language; we provide our own build tools. 5 | language: generic 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | 14 | matrix: 15 | include: 16 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 17 | compiler: ": #GHC 8.0.2" 18 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 19 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 20 | compiler: ": #GHC 8.2.2" 21 | addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 22 | # Build with the newest GHC and cabal-install. This is an accepted failure, 23 | # see below. 24 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 25 | compiler: ": #GHC HEAD" 26 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 27 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 28 | # variable, such as using --stack-yaml to point to a different file. 29 | - env: BUILD=stack ARGS="" 30 | compiler: ": #stack default" 31 | addons: {apt: {packages: [libgmp-dev]}} 32 | - env: BUILD=stack ARGS="--resolver lts-9" 33 | compiler: ": #stack 8.0.2" 34 | addons: {apt: {packages: [libgmp-dev]}} 35 | - env: BUILD=stack ARGS="--resolver lts-11" 36 | compiler: ": #stack 8.2.2" 37 | addons: {apt: {packages: [libgmp-dev]}} 38 | # Nightly builds are allowed to fail 39 | - env: BUILD=stack ARGS="--resolver nightly" 40 | compiler: ": #stack nightly" 41 | addons: {apt: {packages: [libgmp-dev]}} 42 | 43 | # Build on macOS in addition to Linux 44 | - env: BUILD=stack ARGS="" 45 | compiler: ": #stack default osx" 46 | os: osx 47 | 48 | - env: BUILD=stack ARGS="--resolver lts-9" 49 | compiler: ": #stack 8.0.2 osx" 50 | os: osx 51 | 52 | - env: BUILD=stack ARGS="--resolver lts-11" 53 | compiler: ": #stack 8.2.2 osx" 54 | os: osx 55 | 56 | allow_failures: 57 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 58 | - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 # TODO: I need to figure out why this one fails with /home/travis/.cabal/logs/ghc-8.2.2/integer-logarithms-1.0.2.1-2a6l3Ge7uAMKtkov70g6We.log: openFile: does not exist (No such file or directory) 59 | - env: BUILD=stack ARGS="--resolver nightly" 60 | # TODO: on MacOS it the following builds will fail with `error: non-portable path to file '".stack-work/dist/x86_64-osx/Cabal-2.0.1.0/build/Argon/autogen/cabal_macros.h"';` 61 | - os: osx 62 | 63 | before_install: 64 | # Using compiler above sets CC to an invalid value, so unset it 65 | - unset CC 66 | 67 | # We want to always allow newer versions of packages when building on GHC HEAD 68 | - CABALARGS="" 69 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 70 | 71 | # Download and unpack the stack executable 72 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 73 | - mkdir -p ~/.local/bin 74 | - | 75 | if [ `uname` = "Darwin" ] 76 | then 77 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 78 | else 79 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 80 | fi 81 | 82 | # Use the more reliable S3 mirror of Hackage 83 | mkdir -p $HOME/.cabal 84 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 85 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 86 | 87 | if [ "$CABALVER" != "1.16" ] 88 | then 89 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 90 | fi 91 | 92 | install: 93 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 94 | - if [ -f configure.ac ]; then autoreconf -i; fi 95 | - | 96 | set -ex 97 | case "$BUILD" in 98 | stack) 99 | # Add in extra-deps for older snapshots, as necessary 100 | stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 101 | stack --no-terminal $ARGS build cabal-install && \ 102 | stack --no-terminal $ARGS solver --update-config) 103 | 104 | # Build the dependencies 105 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 106 | ;; 107 | cabal) 108 | cabal --version 109 | travis_retry cabal update 110 | 111 | # Get the list of packages from the stack.yaml file. Note that 112 | # this will also implicitly run hpack as necessary to generate 113 | # the .cabal files needed by cabal-install. 114 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 115 | 116 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 117 | ;; 118 | esac 119 | set +ex 120 | 121 | script: 122 | - | 123 | set -ex 124 | case "$BUILD" in 125 | stack) 126 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --coverage --pedantic 127 | ;; 128 | cabal) 129 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 130 | 131 | ORIGDIR=$(pwd) 132 | for dir in $PACKAGES 133 | do 134 | cd $dir 135 | cabal check || [ "$CABALVER" == "1.16" ] 136 | cabal sdist 137 | PKGVER=$(cabal info . | awk '{print $2;exit}') 138 | SRC_TGZ=$PKGVER.tar.gz 139 | cd dist 140 | tar zxfv "$SRC_TGZ" 141 | cd "$PKGVER" 142 | cabal configure --enable-tests --ghc-options -O0 143 | cabal build 144 | cabal test 145 | cd $ORIGDIR 146 | done 147 | ;; 148 | esac 149 | set +ex 150 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 |

2 | 3 | Argon 4 | 5 |

6 | 7 |

8 | 9 | Tests 11 | 12 | 13 | Code coverage 15 | 16 | 17 | License 19 | 20 | 21 | Version 23 | 24 |

25 | 26 |

27 | Argon measures your code's cyclomatic complexity. 28 |

29 | 30 |

31 | Argon screenshot 33 |

34 | 35 |
36 | 37 | ### Installing 38 | 39 | Simple as ``stack install argon`` or ``cabal install argon``. 40 | Note: if you are using Stack and your resolver if too old, you might have to 41 | add some packages to your `stack.yaml` file. 42 | 43 | #### GHC compatibility 44 | 45 | Argon is compatible with GHC version 8.0.2 and above. In the 46 | [releases](https://github.com/rubik/argon/releases) page you can find binaries 47 | for older versions of `argon` which support GHC versions 7.8 and 7.10. 48 | 49 | ### About the complexity being measured 50 | 51 | `argon` will compute the [cyclomatic 52 | complexity](https://en.wikipedia.org/wiki/Cyclomatic_complexity) of Haskell 53 | functions, which is the number of decisions in a block of code plus 1. For 54 | instance the following function: 55 | 56 | ```haskell 57 | func n = case n of 58 | 2 -> 3 59 | 4 -> 6 60 | _ -> 42 61 | ``` 62 | 63 | has a cyclomatic complexity of 3. 64 | 65 | The boolean operators `&&` and `||` also affect the this number. For instance 66 | the following function: 67 | 68 | ```haskell 69 | g n = n < 68 && n `mod` 3 == 2 && n > 49 70 | ``` 71 | has a cyclomatic complexity of 3. 72 | 73 | As a last example, the following function: 74 | 75 | ```haskell 76 | func n = case n of 77 | 2 -> 3 78 | 4 -> 6 79 | _ -> if 0 < n 80 | then 7 81 | else 8 82 | ``` 83 | 84 | has a cyclomatic complexity of 5. 85 | 86 | Cyclomatic complexity provides a very shallow metric of code complexity: a high 87 | cyclomatic complexity number does not necessarily mean that the function is 88 | complex, and conversely, a low number does not necessarily indicate that the 89 | function is simple. However, this number it can be useful for highlighting 90 | potential maintainability issues. 91 | 92 | ### Running 93 | 94 | The Argon executable expects a list of file paths (files or directories): 95 | 96 | $ argon --no-color --min 2 src 97 | src/Argon/Types.hs 98 | 61:5 toJSON - 2 99 | src/Argon/Visitor.hs 100 | 55:1 visitExp - 5 101 | 62:1 visitOp - 4 102 | 28:11 visit - 2 103 | 35:1 getFuncName - 2 104 | src/Argon/Parser.hs 105 | 55:1 parseModuleWithCpp - 3 106 | 88:1 customLogAction - 3 107 | 35:1 analyze - 2 108 | 39:9 analysis - 2 109 | src/Argon/Formatters.hs 110 | 61:1 formatResult - 3 111 | 42:1 coloredFunc - 2 112 | 43:11 color - 2 113 | src/Argon/Results.hs 114 | 35:1 export - 3 115 | 28:1 filterResults - 2 116 | src/Argon/Loc.hs 117 | 18:11 toRealSrcLoc - 2 118 | 119 | For every file, Argon sorts results with the following criteria (and in this 120 | order): 121 | 122 | 1. complexity (descending) 123 | 2. line number (ascending) 124 | 3. alphabetically 125 | 126 | When colors are enabled (default), Argon computes a rank associated with the 127 | complexity score: 128 | 129 | | Complexity | Rank | 130 | |:----------:|:----:| 131 | | 0..5 | A | 132 | | 5..10 | B | 133 | | above 10 | C | 134 | 135 | 136 | #### JSON 137 | 138 | Results can also be exported to JSON: 139 | ```json 140 | $ argon --json --min 2 src 141 | [ 142 | { "blocks": [ ], "path": "src/Argon.hs", "type": "result" }, 143 | { 144 | "blocks": [{ "complexity": 2, "name": "toJSON", "lineno": 61, "col": 5 }], 145 | "path": "src/Argon/Types.hs", 146 | "type": "result" 147 | }, 148 | { 149 | "blocks": [ 150 | { "complexity": 5, "name": "visitExp", "lineno": 55, "col": 1 }, 151 | { "complexity": 4, "name": "visitOp", "lineno": 62, "col": 1 }, 152 | { "complexity": 2, "name": "visit", "lineno": 28, "col": 11 }, 153 | { "complexity": 2, "name": "getFuncName", "lineno": 35, "col": 1 } 154 | ], 155 | "path": "src/Argon/Visitor.hs", 156 | "type": "result" 157 | }, 158 | { 159 | "blocks": [ 160 | { "complexity": 3, "name": "parseModuleWithCpp", "lineno": 55, "col": 1 }, 161 | { "complexity": 3, "name": "customLogAction", "lineno": 88, "col": 1 }, 162 | { "complexity": 2, "name": "analyze", "lineno": 35, "col": 1 }, 163 | { "complexity": 2, "name": "analysis", "lineno": 39, "col": 9 } 164 | ], 165 | "path": "src/Argon/Parser.hs", 166 | "type": "result" 167 | }, 168 | { 169 | "blocks": [ 170 | { "complexity": 3, "name": "formatResult", "lineno": 61, "col": 1 }, 171 | { "complexity": 2, "name": "coloredFunc", "lineno": 42, "col": 1 }, 172 | { "complexity": 2, "name": "color", "lineno": 43, "col": 11 } 173 | ], 174 | "path": "src/Argon/Formatters.hs", 175 | "type": "result" 176 | }, 177 | { 178 | "blocks": [ 179 | { "complexity": 3, "name": "export", "lineno": 35, "col": 1 }, 180 | { "complexity": 2, "name": "filterResults", "lineno": 28, "col": 1 } 181 | ], 182 | "path": "src/Argon/Results.hs", 183 | "type": "result" 184 | }, 185 | { 186 | "blocks": [{ "complexity": 2, "name": "toRealSrcLoc", "lineno": 18, "col": 11 }], 187 | "path": "src/Argon/Loc.hs", 188 | "type": "result" 189 | }, 190 | { "blocks": [ ], "path": "src/Argon/Preprocess.hs", "type": "result" } 191 | ] 192 | ``` 193 | -------------------------------------------------------------------------------- /test/data/cabal_macros.h: -------------------------------------------------------------------------------- 1 | /* DO NOT EDIT: This file is automatically generated by Cabal */ 2 | 3 | /* package Cabal-1.22.4.0 */ 4 | #define VERSION_Cabal "1.22.4.0" 5 | #define MIN_VERSION_Cabal(major1,major2,minor) (\ 6 | (major1) < 1 || \ 7 | (major1) == 1 && (major2) < 22 || \ 8 | (major1) == 1 && (major2) == 22 && (minor) <= 4) 9 | 10 | /* package aeson-0.8.0.2 */ 11 | #define VERSION_aeson "0.8.0.2" 12 | #define MIN_VERSION_aeson(major1,major2,minor) (\ 13 | (major1) < 0 || \ 14 | (major1) == 0 && (major2) < 8 || \ 15 | (major1) == 0 && (major2) == 8 && (minor) <= 0) 16 | 17 | /* package ansi-terminal-0.6.2.3 */ 18 | #define VERSION_ansi_terminal "0.6.2.3" 19 | #define MIN_VERSION_ansi_terminal(major1,major2,minor) (\ 20 | (major1) < 0 || \ 21 | (major1) == 0 && (major2) < 6 || \ 22 | (major1) == 0 && (major2) == 6 && (minor) <= 2) 23 | 24 | /* package base-4.8.1.0 */ 25 | #define VERSION_base "4.8.1.0" 26 | #define MIN_VERSION_base(major1,major2,minor) (\ 27 | (major1) < 4 || \ 28 | (major1) == 4 && (major2) < 8 || \ 29 | (major1) == 4 && (major2) == 8 && (minor) <= 1) 30 | 31 | /* package bytestring-0.10.6.0 */ 32 | #define VERSION_bytestring "0.10.6.0" 33 | #define MIN_VERSION_bytestring(major1,major2,minor) (\ 34 | (major1) < 0 || \ 35 | (major1) == 0 && (major2) < 10 || \ 36 | (major1) == 0 && (major2) == 10 && (minor) <= 6) 37 | 38 | /* package containers-0.5.6.2 */ 39 | #define VERSION_containers "0.5.6.2" 40 | #define MIN_VERSION_containers(major1,major2,minor) (\ 41 | (major1) < 0 || \ 42 | (major1) == 0 && (major2) < 5 || \ 43 | (major1) == 0 && (major2) == 5 && (minor) <= 6) 44 | 45 | /* package directory-1.2.2.0 */ 46 | #define VERSION_directory "1.2.2.0" 47 | #define MIN_VERSION_directory(major1,major2,minor) (\ 48 | (major1) < 1 || \ 49 | (major1) == 1 && (major2) < 2 || \ 50 | (major1) == 1 && (major2) == 2 && (minor) <= 2) 51 | 52 | /* package ghc-7.10.2 */ 53 | #define VERSION_ghc "7.10.2" 54 | #define MIN_VERSION_ghc(major1,major2,minor) (\ 55 | (major1) < 7 || \ 56 | (major1) == 7 && (major2) < 10 || \ 57 | (major1) == 7 && (major2) == 10 && (minor) <= 2) 58 | 59 | /* package ghc-paths-0.1.0.9 */ 60 | #define VERSION_ghc_paths "0.1.0.9" 61 | #define MIN_VERSION_ghc_paths(major1,major2,minor) (\ 62 | (major1) < 0 || \ 63 | (major1) == 0 && (major2) < 1 || \ 64 | (major1) == 0 && (major2) == 1 && (minor) <= 0) 65 | 66 | /* package ghc-syb-utils-0.2.3 */ 67 | #define VERSION_ghc_syb_utils "0.2.3" 68 | #define MIN_VERSION_ghc_syb_utils(major1,major2,minor) (\ 69 | (major1) < 0 || \ 70 | (major1) == 0 && (major2) < 2 || \ 71 | (major1) == 0 && (major2) == 2 && (minor) <= 3) 72 | 73 | /* package lens-simple-0.1.0.8 */ 74 | #define VERSION_lens_simple "0.1.0.8" 75 | #define MIN_VERSION_lens_simple(major1,major2,minor) (\ 76 | (major1) < 0 || \ 77 | (major1) == 0 && (major2) < 1 || \ 78 | (major1) == 0 && (major2) == 1 && (minor) <= 0) 79 | 80 | /* package pipes-4.1.6 */ 81 | #define VERSION_pipes "4.1.6" 82 | #define MIN_VERSION_pipes(major1,major2,minor) (\ 83 | (major1) < 4 || \ 84 | (major1) == 4 && (major2) < 1 || \ 85 | (major1) == 4 && (major2) == 1 && (minor) <= 6) 86 | 87 | /* package pipes-bytestring-2.1.1 */ 88 | #define VERSION_pipes_bytestring "2.1.1" 89 | #define MIN_VERSION_pipes_bytestring(major1,major2,minor) (\ 90 | (major1) < 2 || \ 91 | (major1) == 2 && (major2) < 1 || \ 92 | (major1) == 2 && (major2) == 1 && (minor) <= 1) 93 | 94 | /* package pipes-files-0.1.1 */ 95 | #define VERSION_pipes_files "0.1.1" 96 | #define MIN_VERSION_pipes_files(major1,major2,minor) (\ 97 | (major1) < 0 || \ 98 | (major1) == 0 && (major2) < 1 || \ 99 | (major1) == 0 && (major2) == 1 && (minor) <= 1) 100 | 101 | /* package pipes-group-1.0.3 */ 102 | #define VERSION_pipes_group "1.0.3" 103 | #define MIN_VERSION_pipes_group(major1,major2,minor) (\ 104 | (major1) < 1 || \ 105 | (major1) == 1 && (major2) < 0 || \ 106 | (major1) == 1 && (major2) == 0 && (minor) <= 3) 107 | 108 | /* package pipes-safe-2.2.3 */ 109 | #define VERSION_pipes_safe "2.2.3" 110 | #define MIN_VERSION_pipes_safe(major1,major2,minor) (\ 111 | (major1) < 2 || \ 112 | (major1) == 2 && (major2) < 2 || \ 113 | (major1) == 2 && (major2) == 2 && (minor) <= 3) 114 | 115 | /* package syb-0.5.1 */ 116 | #define VERSION_syb "0.5.1" 117 | #define MIN_VERSION_syb(major1,major2,minor) (\ 118 | (major1) < 0 || \ 119 | (major1) == 0 && (major2) < 5 || \ 120 | (major1) == 0 && (major2) == 5 && (minor) <= 1) 121 | 122 | /* package docopt-0.7.0.4 */ 123 | #define VERSION_docopt "0.7.0.4" 124 | #define MIN_VERSION_docopt(major1,major2,minor) (\ 125 | (major1) < 0 || \ 126 | (major1) == 0 && (major2) < 7 || \ 127 | (major1) == 0 && (major2) == 7 && (minor) <= 0) 128 | 129 | /* package QuickCheck-2.8.1 */ 130 | #define VERSION_QuickCheck "2.8.1" 131 | #define MIN_VERSION_QuickCheck(major1,major2,minor) (\ 132 | (major1) < 2 || \ 133 | (major1) == 2 && (major2) < 8 || \ 134 | (major1) == 2 && (major2) == 8 && (minor) <= 1) 135 | 136 | /* package filepath-1.4.0.0 */ 137 | #define VERSION_filepath "1.4.0.0" 138 | #define MIN_VERSION_filepath(major1,major2,minor) (\ 139 | (major1) < 1 || \ 140 | (major1) == 1 && (major2) < 4 || \ 141 | (major1) == 1 && (major2) == 4 && (minor) <= 0) 142 | 143 | /* package hspec-2.1.10 */ 144 | #define VERSION_hspec "2.1.10" 145 | #define MIN_VERSION_hspec(major1,major2,minor) (\ 146 | (major1) < 2 || \ 147 | (major1) == 2 && (major2) < 1 || \ 148 | (major1) == 2 && (major2) == 1 && (minor) <= 10) 149 | 150 | /* package hlint-1.9.21 */ 151 | #define VERSION_hlint "1.9.21" 152 | #define MIN_VERSION_hlint(major1,major2,minor) (\ 153 | (major1) < 1 || \ 154 | (major1) == 1 && (major2) < 9 || \ 155 | (major1) == 1 && (major2) == 9 && (minor) <= 21) 156 | 157 | /* tool cpphs-1.19.3 */ 158 | #define TOOL_VERSION_cpphs "1.19.3" 159 | #define MIN_TOOL_VERSION_cpphs(major1,major2,minor) (\ 160 | (major1) < 1 || \ 161 | (major1) == 1 && (major2) < 19 || \ 162 | (major1) == 1 && (major2) == 19 && (minor) <= 3) 163 | 164 | /* tool gcc-5.2.0 */ 165 | #define TOOL_VERSION_gcc "5.2.0" 166 | #define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\ 167 | (major1) < 5 || \ 168 | (major1) == 5 && (major2) < 2 || \ 169 | (major1) == 5 && (major2) == 2 && (minor) <= 0) 170 | 171 | /* tool ghc-7.10.2 */ 172 | #define TOOL_VERSION_ghc "7.10.2" 173 | #define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\ 174 | (major1) < 7 || \ 175 | (major1) == 7 && (major2) < 10 || \ 176 | (major1) == 7 && (major2) == 10 && (minor) <= 2) 177 | 178 | /* tool ghc-pkg-7.10.2 */ 179 | #define TOOL_VERSION_ghc_pkg "7.10.2" 180 | #define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\ 181 | (major1) < 7 || \ 182 | (major1) == 7 && (major2) < 10 || \ 183 | (major1) == 7 && (major2) == 10 && (minor) <= 2) 184 | 185 | /* tool haddock-2.16.1 */ 186 | #define TOOL_VERSION_haddock "2.16.1" 187 | #define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\ 188 | (major1) < 2 || \ 189 | (major1) == 2 && (major2) < 16 || \ 190 | (major1) == 2 && (major2) == 16 && (minor) <= 1) 191 | 192 | /* tool happy-1.19.5 */ 193 | #define TOOL_VERSION_happy "1.19.5" 194 | #define MIN_TOOL_VERSION_happy(major1,major2,minor) (\ 195 | (major1) < 1 || \ 196 | (major1) == 1 && (major2) < 19 || \ 197 | (major1) == 1 && (major2) == 19 && (minor) <= 5) 198 | 199 | /* tool hpc-0.67 */ 200 | #define TOOL_VERSION_hpc "0.67" 201 | #define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\ 202 | (major1) < 0 || \ 203 | (major1) == 0 && (major2) < 67 || \ 204 | (major1) == 0 && (major2) == 67 && (minor) <= 0) 205 | 206 | /* tool hsc2hs-0.67 */ 207 | #define TOOL_VERSION_hsc2hs "0.67" 208 | #define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\ 209 | (major1) < 0 || \ 210 | (major1) == 0 && (major2) < 67 || \ 211 | (major1) == 0 && (major2) == 67 && (minor) <= 0) 212 | 213 | /* tool hscolour-1.22 */ 214 | #define TOOL_VERSION_hscolour "1.22" 215 | #define MIN_TOOL_VERSION_hscolour(major1,major2,minor) (\ 216 | (major1) < 1 || \ 217 | (major1) == 1 && (major2) < 22 || \ 218 | (major1) == 1 && (major2) == 22 && (minor) <= 0) 219 | 220 | /* tool pkg-config-0.29 */ 221 | #define TOOL_VERSION_pkg_config "0.29" 222 | #define MIN_TOOL_VERSION_pkg_config(major1,major2,minor) (\ 223 | (major1) < 0 || \ 224 | (major1) == 0 && (major2) < 29 || \ 225 | (major1) == 0 && (major2) == 29 && (minor) <= 0) 226 | 227 | /* tool strip-2.25 */ 228 | #define TOOL_VERSION_strip "2.25" 229 | #define MIN_TOOL_VERSION_strip(major1,major2,minor) (\ 230 | (major1) < 2 || \ 231 | (major1) == 2 && (major2) < 25 || \ 232 | (major1) == 2 && (major2) == 25 && (minor) <= 0) 233 | 234 | #define CURRENT_PACKAGE_KEY "argon_EPnFAvdLsdbDHKR24nicp7" 235 | 236 | -------------------------------------------------------------------------------- /test/ArgonSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module ArgonSpec (spec) 6 | where 7 | 8 | import Data.Aeson (encode) 9 | import Data.List (sort) 10 | import GHC.Stack (HasCallStack) 11 | import Text.Printf (printf) 12 | #if __GLASGOW_HASKELL__ < 710 13 | import Control.Applicative ((<$>), (<*>)) 14 | #endif 15 | import qualified FastString as GHC 16 | import Pipes (Producer, (>->), each) 17 | import qualified SrcLoc as GHC 18 | import System.Console.ANSI (Color (..), ConsoleIntensity(BoldIntensity), setSGRCode, 19 | SGR(SetColor, SetConsoleIntensity), 20 | ConsoleLayer(Foreground), ColorIntensity(Dull)) 21 | import System.FilePath (()) 22 | import System.IO.Unsafe (unsafePerformIO) 23 | import Test.Hspec (describe, it, Expectation, shouldBe, 24 | shouldContain, Spec, expectationFailure, 25 | shouldReturn) 26 | import Test.QuickCheck (Arbitrary, arbitrary, shrink, property, elements) 27 | import qualified Pipes.Prelude as P 28 | import Data.Foldable (traverse_) 29 | 30 | import Argon 31 | 32 | instance Arbitrary ComplexityBlock where 33 | arbitrary = (\a b c -> CC (a, b, c)) <$> arbitrary 34 | <*> arbitrary 35 | <*> arbitrary 36 | shrink (CC t) = map CC $ shrink t 37 | 38 | instance Arbitrary OutputMode where 39 | arbitrary = elements [BareText, Colored, JSON] 40 | 41 | ones :: Loc 42 | ones = (1, 1) 43 | 44 | lo :: Int -> Loc 45 | lo s = (s, 1) 46 | 47 | realSpan :: Int -> Int -> GHC.SrcSpan 48 | realSpan a b = GHC.mkSrcSpan (mkLoc a b) $ mkLoc (-a) (b + 24) 49 | where mkLoc = GHC.mkSrcLoc (GHC.mkFastString "real loc") 50 | 51 | shouldContainErrors :: HasCallStack => FilePath -> [String] -> Expectation 52 | shouldContainErrors f errs = do 53 | r <- analyze defaultConfig (path f) 54 | case r of 55 | (_, Right _) -> expectationFailure $ "Test did not fail" ++ show r 56 | (_, Left msg) -> traverse_ (msg `shouldContain`) errs 57 | 58 | path :: String -> FilePath 59 | path f = "test" "data" f 60 | 61 | shouldAnalyze :: HasCallStack => String -> AnalysisResult -> Expectation 62 | shouldAnalyze f = shouldAnalyzeC (f, defaultConfig) 63 | 64 | shouldAnalyzeC :: HasCallStack => (String, Config) -> AnalysisResult -> Expectation 65 | shouldAnalyzeC (f, config) r = analyze config p `shouldReturn` (p, r) 66 | where p = path f 67 | 68 | -- Disabled until I figure out why Argon.Walker tests fail only on Travis 69 | {-shouldProduceS :: Producer FilePath (SafeT IO) () -> [FilePath] -> Expectation-} 70 | {-shouldProduceS prod res = do-} 71 | {-paths <- runSafeT $ P.toListM prod-} 72 | {-paths `shouldBe` res-} 73 | 74 | shouldProduce :: (Eq a, Show a) => Producer a IO () -> [a] -> Expectation 75 | shouldProduce prod res = P.toListM prod >>= (`shouldBe` res) 76 | 77 | produceError, produceResult :: Producer (FilePath, AnalysisResult) IO () 78 | produceError = each [("path/f.hs", Left "err!")] 79 | produceResult = each [("f.hs", Right [ CC (ones, "g", 3) 80 | , CC (lo 2, "h", 5) 81 | , CC (lo 5, "f", 6) 82 | , CC (lo 7, "m", 10) 83 | , CC ((9, 2), "n", 15) 84 | ])] 85 | 86 | -- | ANSI bold color 87 | bold :: String 88 | bold = setSGRCode [SetConsoleIntensity BoldIntensity] 89 | 90 | -- | Make a ANSI foreground color sequence 91 | fore :: Color -> String 92 | fore color = setSGRCode [SetColor Foreground Dull color] 93 | 94 | -- | ANSI sequence for reset 95 | reset :: String 96 | reset = setSGRCode [] 97 | 98 | spec :: Spec 99 | spec = do 100 | describe "analyze" $ do 101 | it "accounts for case" $ 102 | "case.hs" `shouldAnalyze` Right [CC (ones, "func", 3)] 103 | it "accounts for if..then..else" $ 104 | "ifthenelse.hs" `shouldAnalyze` Right [CC (ones, "f", 2)] 105 | it "accounts for lambda case" $ 106 | "lambdacase.hs" `shouldAnalyze` Right [CC (lo 2, "g", 3)] 107 | it "accounts for multi way if" $ 108 | "multiif.hs" `shouldAnalyze` Right [CC (lo 2, "f", 4)] 109 | it "accounts for || operator" $ 110 | "orop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)] 111 | it "accounts for && operator" $ 112 | "andop.hs" `shouldAnalyze` Right [CC (lo 1, "g", 3)] 113 | it "counts everything in a real example" $ 114 | "stack-setup.hs" `shouldAnalyze` 115 | Right [ CC (lo 3, "ensureCompiler", 14) 116 | , CC ((4, 9), "wc", 1) 117 | , CC ((21, 9), "needLocal", 4) 118 | , CC ((27, 9), "isWanted", 1) 119 | , CC ((41, 17), "installedCompiler", 2) 120 | , CC ((81, 37), "tool", 1) 121 | , CC ((94, 17), "idents", 1) 122 | , CC ((103, 21), "m", 1) 123 | ] 124 | describe "extensions" $ do 125 | -- Not even GHC 7.8.4 is able to run the file below, so it's not an Argon bug 126 | #if __GLASGOW_HASKELL__ >= 710 127 | it "correctly applies CPP" $ 128 | "cpp-psyn.hs" `shouldAnalyze` Right [] 129 | #endif 130 | it "applies CPP when needed" $ 131 | "cpp.hs" `shouldAnalyze` Right [CC (lo 5, "f", 4)] 132 | it "works with TemplateHaskell" $ 133 | "th.hs" `shouldAnalyze` Right [CC (lo 7, "foo", 1)] 134 | it "works with DataKinds, GADTs, KindSignatures" $ 135 | "datakinds.hs" `shouldAnalyze` 136 | Right [ CC (lo 16, "taskOneWorker", 1) 137 | , CC (lo 20, "main", 1)] 138 | it "works with ScopedTypeVariables" $ 139 | "scopedtypevariables.hs" `shouldAnalyze` 140 | Right [CC (lo 9, "catchNonAsync", 1)] 141 | it "works with TypeFamilies" $ 142 | "typefamilies.hs" `shouldAnalyze` Right [] 143 | it "works with ForeignImport" $ 144 | "foreignimports.hs" `shouldAnalyze` Right [] 145 | it "works with Arrows" $ 146 | "arrows.hs" `shouldAnalyze` Right [CC (lo 7, "getAnchor", 1)] 147 | describe "errors" $ do 148 | it "catches syntax errors" $ 149 | "syntaxerror.hs" `shouldContainErrors` 150 | ["parse error (possibly incorrect indentation or mismatched brackets)"] 151 | it "catches syntax errors (missing CPP)" $ 152 | "missingcpp.hs" `shouldAnalyze` 153 | #if __GLASGOW_HASKELL__ < 800 154 | Left "1:2 lexical error at character 'i'" 155 | #else 156 | Left "1:1 parse error on input \8216#\8217" 157 | #endif 158 | #if __GLASGOW_HASKELL__ < 800 159 | -- The analysis of "missingmacros.hs" will succeed in newest GHC versions. 160 | it "catches syntax errors (missing cabal macros)" $ 161 | "missingmacros.hs" `shouldContainErrors` 162 | ["error: missing binary operator before token "] 163 | #endif 164 | it "catches syntax errors (missing include dir)" $ 165 | "missingincluded.hs" `shouldContainErrors` 166 | ["fatal error", "necessaryInclude.h"] 167 | it "catches CPP parsing errors" $ 168 | "cpp-error.hs" `shouldContainErrors` 169 | ["error: unterminated"] 170 | describe "config" $ do 171 | it "reads default extensions from Cabal file" $ 172 | ("missingcpp.hs", unsafePerformIO 173 | (do loadedExts <- parseExts $ path "test.cabal" 174 | return $ defaultConfig { exts = loadedExts })) 175 | `shouldAnalyzeC` 176 | Right [CC (lo 4, "f", 1)] 177 | it "reads other extensions from Cabal file" $ 178 | ("missingcpp.hs", unsafePerformIO 179 | (do loadedExts <- parseExts $ path "test-other.cabal" 180 | return $ defaultConfig { exts = loadedExts })) 181 | `shouldAnalyzeC` 182 | Right [CC (lo 4, "f", 1)] 183 | it "reads old extensions from Cabal file" $ 184 | ("missingcpp.hs", unsafePerformIO 185 | (do loadedExts <- parseExts $ path "test-old.cabal" 186 | return $ defaultConfig { exts = loadedExts })) 187 | `shouldAnalyzeC` 188 | Right [CC (lo 4, "f", 1)] 189 | #if __GLASGOW_HASKELL__ < 800 190 | it "includes Cabal macros for preprocessing" $ 191 | ( "missingmacros.hs" 192 | , defaultConfig { headers = [path "cabal_macros.h"] } 193 | ) `shouldAnalyzeC` Right [CC (lo 3, "f", 2)] 194 | #endif 195 | it "includes directory from include-dir for preprocessing" $ 196 | ( "missingincluded.hs" 197 | , defaultConfig { includeDirs = [path "include"] } 198 | ) `shouldAnalyzeC` Right [CC (lo 5, "f", 3)] 199 | describe "Argon.Loc" $ do 200 | describe "srcSpanToLoc" $ do 201 | it "can convert a real src span to loc" $ 202 | property $ \a b -> srcSpanToLoc (realSpan a b) == (a, b) 203 | it "can convert a bad src span to loc" $ 204 | srcSpanToLoc GHC.noSrcSpan `shouldBe` (0, 0) 205 | describe "locToString" $ 206 | it "can convert a loc to string" $ 207 | locToString (1, 30) `shouldBe` "1:30" 208 | describe "tagMsg" $ 209 | it "can tag messages" $ 210 | tagMsg (2, 3) "my custom msg" `shouldBe` "2:3 my custom msg" 211 | describe "Argon.Results" $ do 212 | describe "order" $ do 213 | it "does not error on empty list" $ 214 | order [] `shouldBe` [] 215 | it "orders by complexity (descending)" $ 216 | order [CC (ones, "f", 1), CC (lo 2, "f", 2)] `shouldBe` 217 | [CC (lo 2, "f", 2), CC (ones, "f", 1)] 218 | it "orders by lines (ascending)" $ 219 | order [CC (lo 11, "f", 3), CC (ones, "f", 3)] `shouldBe` 220 | [CC (ones, "f", 3), CC (lo 11, "f", 3)] 221 | it "orders by function name (ascending)" $ 222 | order [CC (lo 11, "g", 3), CC (lo 11, "f", 3)] `shouldBe` 223 | [CC (lo 11, "f", 3), CC (lo 11, "g", 3)] 224 | it "does not add or remove elements" $ 225 | property $ \xs -> sort xs == sort (order xs) 226 | it "is idempotent" $ 227 | property $ \xs -> order xs == order (order xs) 228 | describe "filterNulls" $ do 229 | it "allows errors" $ 230 | filterNulls ("", Left "err") `shouldBe` True 231 | it "disallows empty results" $ 232 | filterNulls ("", Right []) `shouldBe` False 233 | it "always allows non-empty results" $ 234 | property $ \x -> filterNulls ("", Right [x]) 235 | describe "filterResults" $ do 236 | it "discards results with too low complexity" $ 237 | filterResults (Config 3 [] [] [] BareText ) 238 | ("p", Right [ CC (ones, "f", 3) 239 | , CC (lo 2, "g", 2) 240 | , CC (lo 4, "h", 10) 241 | , CC (lo 3, "l", 1)]) 242 | `shouldBe` 243 | ("p", Right [ CC (lo 4, "h", 10) 244 | , CC (ones, "f", 3)]) 245 | it "does nothing on Left" $ 246 | property $ \m o p err -> filterResults (Config m [] [] [] o) 247 | (p, Left err) == 248 | (p, Left err) 249 | describe "Argon.Formatters" $ do 250 | describe "bareTextFormatter" $ do 251 | it "correctly formats errors" $ 252 | (produceError >-> bareTextFormatter) `shouldProduce` 253 | ["path/f.hs", "\terror: err!"] 254 | it "correctly formats results" $ 255 | (produceResult >-> bareTextFormatter) `shouldProduce` 256 | [ "f.hs" 257 | , "\t1:1 g - 3" 258 | , "\t2:1 h - 5" 259 | , "\t5:1 f - 6" 260 | , "\t7:1 m - 10" 261 | , "\t9:2 n - 15" 262 | ] 263 | describe "coloredTextFormatter" $ do 264 | it "correctly formats errors" $ 265 | (produceError >-> coloredTextFormatter) `shouldProduce` 266 | [ bold ++ "path/f.hs" ++ reset 267 | , "\t" ++ fore Red ++ "error" ++ reset ++ ": err!" 268 | ] 269 | it "correctly formats results" $ 270 | (produceResult >-> coloredTextFormatter) `shouldProduce` 271 | [ bold ++ "f.hs" ++ reset 272 | , printf "\t1:1 %sg%s - %sA (3)%s" (fore Cyan) reset 273 | (fore Green) reset 274 | , printf "\t2:1 %sh%s - %sA (5)%s" (fore Cyan) reset 275 | (fore Green) reset 276 | , printf "\t5:1 %sf%s - %sB (6)%s" (fore Cyan) reset 277 | (fore Yellow) reset 278 | , printf "\t7:1 %sm%s - %sB (10)%s" (fore Cyan) reset 279 | (fore Yellow) reset 280 | , printf "\t9:2 %sn%s - %sC (15)%s" (fore Magenta) reset 281 | (fore Red) reset 282 | ] 283 | describe "Argon.Types" $ do 284 | describe "ComplexityBlock" $ do 285 | it "implements Show correctly" $ 286 | show (CC ((2, 3), "bla bla", 32)) `shouldBe` 287 | "CC ((2,3),\"bla bla\",32)" 288 | it "implements Eq correctly" $ 289 | CC ((1, 4), "fun", 13) `shouldBe` CC ((1, 4), "fun", 13) 290 | it "implements Ord correctly" $ 291 | CC (lo 1, "g", 2) < CC (lo 2, "f", 1) `shouldBe` True 292 | describe "OutputMode" $ do 293 | it "implements Show correctly" $ 294 | show [JSON, Colored, BareText] `shouldBe` 295 | "[JSON,Colored,BareText]" 296 | it "implements Eq correctly" $ 297 | [JSON, Colored, BareText] `shouldBe` [JSON, Colored, BareText] 298 | describe "ToJSON instance" $ do 299 | it "is implemented by ComplexityResult" $ 300 | encode (CC ((1, 3), "f", 4)) `shouldBe` 301 | "{\"complexity\":4,\"name\":\"f\",\"lineno\":1,\"col\":3}" 302 | it "is implemented by (FilePath, AnalysisResult)" $ 303 | encode ("f.hs" :: String, Right [] :: AnalysisResult) 304 | `shouldBe` 305 | "{\"blocks\":[],\"path\":\"f.hs\",\"type\":\"result\"}" 306 | it "is implemented by (FilePath, AnalysisResult) II" $ 307 | encode ("f.hs" :: String, Left "err" :: AnalysisResult) 308 | `shouldBe` 309 | "{\"path\":\"f.hs\",\"type\":\"error\",\"message\":\"err\"}" 310 | #if 0 311 | describe "Argon.Walker" $ 312 | describe "allFiles" $ do 313 | it "traverses the filesystem depth-first" $ 314 | allFiles ("test" "tree") `shouldProduceS` 315 | [ "test" "tree" "sub" "b.hs" 316 | , "test" "tree" "sub" "c.hs" 317 | , "test" "tree" "sub2" "a.hs" 318 | , "test" "tree" "sub2" "e.hs" 319 | , "test" "tree" "a.hs" 320 | ] 321 | it "includes starting files in the result" $ 322 | allFiles ("test" "tree" "a.hs") `shouldProduceS` 323 | ["test" "tree" "a.hs"] 324 | #endif 325 | --------------------------------------------------------------------------------