homplexity 0.4.4.4 → 0.4.6.0

raw patch · 23 files changed

+1012/−337 lines, 23 filesdep +Cabaldep +blaze-htmldep +blaze-markupdep −pqueuedep ~basedep ~haskell-src-extsdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Cabal, blaze-html, blaze-markup, bytestring, githash, hspec

Dependencies removed: pqueue

Dependency ranges changed: base, haskell-src-exts, template-haskell

API changes (from Hackage documentation)

Files

• README.md +8/−0
• app/Homplexity.hs +99/−25
• changelog.md +11/−0
• homplexity.cabal +87/−61
• lib/Language/Haskell/Homplexity/Assessment.hs +82/−41
• lib/Language/Haskell/Homplexity/CabalFiles.hs +213/−0
• lib/Language/Haskell/Homplexity/CodeFragment.hs +59/−20
• lib/Language/Haskell/Homplexity/Comments.hs +4/−5
• lib/Language/Haskell/Homplexity/Cyclomatic.hs +1/−8
• lib/Language/Haskell/Homplexity/Message.hs +46/−17
• lib/Language/Haskell/Homplexity/Metric.hs +12/−12
• lib/Language/Haskell/Homplexity/Parse.hs +68/−50
• lib/Language/Haskell/Homplexity/RecordFieldsCount.hs +49/−0
• lib/Language/Haskell/Homplexity/TypeClassComplexity.hs +65/−0
• lib/Language/Haskell/Homplexity/Utilities.hs +22/−0
• tests/Comments.hs +0/−60
• tests/Test/Metrics/TypeClassComplexitySpec.hs +22/−0
• tests/Test/Parse/CommentsSpec.hs +36/−0
• tests/Test/Parse/ExtensionsSpec.hs +64/−0
• tests/Test/Utilities.hs +25/−0
• tests/Test/Utils.hs +38/−0
• tests/TestSource.hs +0/−38
• tests/Tests.hs +1/−0

@@ -23,6 +23,8 @@  Official releases are on [Hackage](https://hackage.haskell.org/package/homplexity) +[![Gitter](https://badges.gitter.im/homplexity/community.svg)](https://gitter.im/homplexity/community?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge)+ USAGE: ------ After installing with `cabal install homplexity`, you might run it with filenames or directories@@ -35,6 +37,12 @@ Patches and suggestions are welcome.  You may run `homplexity --help` to see options.++For html output, run:+```+    homplexity --format=HTML Main.hs src/ +```+  How does it work? -----------------

@@ -3,22 +3,29 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE CPP                   #-} -- | Main module parsing inputs, and running analysis. module Main (main) where  import Control.Monad(when)+import Data.Either import Data.Functor-import Data.List+import Data.List hiding (head) import Data.Monoid+import Data.Version +import GitHash(giHash, giDirty, giCommitDate, tGitInfoCwdTry, GitInfo)+import HFlags+import Language.Haskell.Exts.Extension import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Syntax import Language.Haskell.Homplexity.Assessment+import Language.Haskell.Homplexity.CabalFiles import Language.Haskell.Homplexity.CodeFragment import Language.Haskell.Homplexity.Message import Language.Haskell.Homplexity.Parse@@ -27,14 +34,40 @@ import System.FilePath import System.IO -import HFlags+import Paths_homplexity(version) +import qualified Prelude as P+import Prelude hiding (head, id, div)+#ifdef HTML_OUTPUT+import qualified Data.ByteString.Lazy as B+import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Utf8+import Text.Blaze.Html4.Strict hiding (map)+--import Text.Blaze.Html4.Strict.Attributes hiding (title, style)+#endif+ -- * Command line flag+defineFlag "v:version" False "Show version"+ defineFlag "severity" Warning (concat ["level of output verbosity (", severityOptions, ")"]) +data OutputFormat =+    Text+#ifdef HTML_OUTPUT+  | HTML+#endif+  deriving (Read, Show)+defineEQFlag "format" [| Text :: OutputFormat |]+#ifdef HTML_OUTPUT+  "{Text|HTML}"+#else+  "{Text}"+#endif+  "What format to use"+ -- | Report to standard error output.-report ::  String -> IO ()-report = hPutStrLn stderr+report :: String -> IO ()+report  = hPutStrLn stderr  -- * Recursing directory tree in order to list Haskell source files. -- | Find all Haskell source files within a given path.@@ -72,39 +105,80 @@ concatMapM f = fmap concat . mapM f  -- * Analysis--- | Analyze a single module.+-- | Analyze a set of modules. analyzeModule :: Module SrcLoc -> IO ()-analyzeModule  = putStr-               . concatMap show+analyzeModule  = out                . extract flags_severity                . mconcat metrics                . program                . (:[])+  where+    out msgs = case flags_format of+                    Text -> do+                      putStr . concatMap show $ msgs+#ifdef HTML_OUTPUT+                    HTML -> B.putStr $ renderHtml $ do+                      html $ do+                        head $ do+                          title (string "Homplexity Analysis.")+                        style $ string style_head+                        body $ do+                          toHtml . fmap toHtml $ msgs+    style_head = ".warning  .severity { color: orange; }" <>+                 ".debug    .severity { color: grey;   }" <>+                 ".critical .severity { color: red;    }"+#endif  -- | Process each separate input file.-processFile ::  FilePath -> IO Bool-processFile filepath = do src <- parseSource filepath-                          case src of-                            Left  msg              -> do report $ show msg-                                                         return False-                            Right (ast, _comments) -> do analyzeModule ast-                                                         return True+processFile :: [Extension] -> FilePath -> IO Bool+processFile additionalExtensions filepath =+    parseSource additionalExtensions filepath >>=+        either (\msg              -> report (show msg) >> return False)+               (\(ast, _comments) -> analyzeModule ast >> return True) + -- | This flag exists only to make sure that HFLags work.+defineFlag "cabal" "" "Project cabal file"++-- | This flag exists only to make sure that HFLags work. defineFlag "fakeFlag" Info "this flag is fake" +gitInfoValue ::Either String GitHash.GitInfo+gitInfoValue  = $$tGitInfoCwdTry++versionString :: String+versionString  = showVersion version <> gitString+  where+    gitString = case gitInfoValue of+                  Left  err     -> "unknown revision: " <> err+                  Right gitInfo -> unwords [+                     "git rev",  giHash       gitInfo+                    ,"dated",    giCommitDate gitInfo+                    ,if          giDirty      gitInfo+                        then     "dirty"+                        else     ""]+ -- | Parse arguments and either process inputs (if available), or suggest proper usage. main :: IO () main = do-  args <- $initHFlags "Homplexity - automatic analysis of Haskell code quality"-  null args `when` do report ("Use Haskell source file or directory as an argument, " ++-                              "or use --help to discover options.")-                      exitFailure-  sums <- mapM processFile =<< concatMapM subTrees args-  case length sums of-    0 -> do report "No valid Haskell source file found!"+  args <- $initHFlags ("Homplexity " ++ versionString ++ " - automatic analysis of Haskell code quality")+  when flags_version $+    report $ unwords ["Version: ", versionString]++  if null args+    then do report ("Use Haskell source file or directory as an argument, " +++                    "or use --help to discover options.")             exitFailure-    n ->    putStrLn $ unwords ["Correctly parsed", show $ length $ filter id sums,-                                "out of",           show n,-                                "input files."]+    else do exts <- cabalExtensions+            sums <- mapM (processFile exts) =<< concatMapM subTrees args+            report $ unwords ["Correctly parsed", show $ length $ filter P.id sums,+                              "out of",           show $ length               sums,+                              "input files."] +cabalExtensions :: IO [Extension]+cabalExtensions+  | null flags_cabal = return []+  | otherwise =+      parseCabalFile flags_cabal >>=+        either (\msg -> report (show msg) >> return [])+               (\cabal -> return $ languageExtensions Library cabal)

@@ -1,5 +1,16 @@ Changelog =========+    0.4.6.0  Feb 2020+        * HTML output+        * GHC 8.8, 8.10 support+        * Automatic detection of language extensions+        * Show --version+        * Record fields count diagnostics+        * Fix handling of critical message priority++    0.4.5.0  Sep 2019+        * Parsing language options.+     0.4.4.4  Nov 2018         * Fix missing pattern for InfixMatch. 

@@ -1,5 +1,5 @@ name:                homplexity-version:             0.4.4.4+version:             0.4.6.0 synopsis:            Haskell code quality tool description:         Homplexity aims to measure code complexity,                      warning about fragments that might have higher defect probability@@ -11,24 +11,25 @@                      .                        * too few comments -homepage:            https://github.com/mgajda/homplexity+homepage:            https://gitlab.com/migamake/homplexity license:             BSD3 license-file:        LICENSE author:              Michal J. Gajda-maintainer:          mjgajda@gmail.com-copyright:           Copyright by Michal J. Gajda '2015-'2018+maintainer:          mjgajda@migamake.com+copyright:           Copyright by Michal J. Gajda and contributors '2015-'2020 https://gitlab.com/migamake/homplexity/-/graphs/master category:            Language, Tools build-type:          Simple extra-source-files:  README.md changelog.md cabal-version:       >=1.10-bug-reports:         https://github.com/mgajda/homplexity/issues-tested-with:         GHC==7.8.4-                   , GHC==7.10.3-                   , GHC==8.0.2-                   , GHC==8.2.2-                   , GHC==8.4.4-                   , GHC==8.6.2+bug-reports:         https://gitlab.com/migamake/homplexity/issues+tested-with:         GHC==8.4.4+                   , GHC==8.6.5+                   , GHC==8.8.2 +Flag Html+  Description: Enable HTML output via blaze-html+  Default:     True+ source-repository head   type:     git   location: https://github.com/mgajda/homplexity.git@@ -36,82 +37,107 @@ Library   exposed-modules:     Language.Haskell.Homplexity.Assessment+    Language.Haskell.Homplexity.CabalFiles     Language.Haskell.Homplexity.CodeFragment     Language.Haskell.Homplexity.Comments     Language.Haskell.Homplexity.Cyclomatic     Language.Haskell.Homplexity.Message     Language.Haskell.Homplexity.Metric     Language.Haskell.Homplexity.Parse-    Language.Haskell.Homplexity.TypeComplexity     Language.Haskell.Homplexity.SrcSlice-  Hs-source-dirs:   lib-  build-tools:         happy            >= 1.19.0+    Language.Haskell.Homplexity.RecordFieldsCount+    Language.Haskell.Homplexity.TypeClassComplexity+    Language.Haskell.Homplexity.TypeComplexity+    Language.Haskell.Homplexity.Utilities+  Hs-source-dirs:      lib   Other-Modules:     Paths_homplexity-  build-depends:       base             >=4.5  && <4.13,-                       haskell-src-exts >=1.18 && <1.21,+  build-depends:       base             >=4.5  && <4.16,+                       bytestring,+                       containers       >=0.3  && <0.7,+                       cpphs            >=1.5  && <1.21,+                       deepseq          >=1.3  && <1.7,                        directory        >=1.1  && <1.4,                        filepath         >=1.2  && <1.5,+                       haskell-src-exts >=1.20 && <1.24,                        hflags           >=0.3  && <0.5,-                       uniplate         >=1.4  && <1.7,-                       deepseq          >=1.3  && <1.7,-                       containers       >=0.3  && <0.7,-                       template-haskell >=2.6  && <2.16,-                       cpphs            >=1.5  && <1.21,-                       pqueue-  other-extensions:    FlexibleContexts,+                       template-haskell >=2.6  && <2.18,+                       uniplate         >=1.4  && <1.7+  if impl(ghc>=8.8.1)+    build-depends:     Cabal            ==3.0.0.0+  else+    build-depends:     Cabal            >=2.2.0.0++  other-extensions:    BangPatterns,+                       DeriveDataTypeable,+                       FlexibleContexts,                        FlexibleInstances,-                       UndecidableInstances,-                       OverlappingInstances,+                       GeneralizedNewtypeDeriving,                        IncoherentInstances,-                       TypeSynonymInstances,-                       DeriveDataTypeable,                        MultiParamTypeClasses,+                       OverlappingInstances,                        RecordWildCards,-                       StandaloneDeriving,                        ScopedTypeVariables,+                       StandaloneDeriving,                        TemplateHaskell,-                       ViewPatterns,-                       BangPatterns,-                       GeneralizedNewtypeDeriving,-                       TypeFamilies+                       TypeFamilies,+                       TypeSynonymInstances,+                       UndecidableInstances,+                       ViewPatterns   default-language:    Haskell2010+  if flag(Html)+    CPP-Options:       -DHTML_OUTPUT+    build-depends:     blaze-html   >= 0.9 && < 1,+                       blaze-markup >= 0.8 && < 0.9  executable homplexity-cli   main-is:             Homplexity.hs   hs-source-dirs:      app/-  build-depends:       base             >=4.5  && <4.13,-                       haskell-src-exts >=1.18 && <1.21,+  build-depends:       base             >=4.5  && <4.16,+                       homplexity,+                       containers       >=0.3  && <0.7,+                       cpphs            >=1.5  && <1.21,+                       deepseq          >=1.3  && <1.7+  Other-Modules:+    Paths_homplexity+  build-depends:       base             >=4.5  && <4.16,                        directory        >=1.1  && <1.4,                        filepath         >=1.2  && <1.5,+                       githash          >=0.1.2.0 && <1.0,+                       haskell-src-exts >=1.20 && <1.24,                        hflags           >=0.3  && <0.5,-                       uniplate         >=1.4  && <1.7,-                       deepseq          >=1.3  && <1.7,-                       containers       >=0.3  && <0.7,-                       template-haskell >=2.6  && <2.16,-                       cpphs            >=1.5  && <1.21,-                       homplexity+                       template-haskell >=2.6  && <2.18,+                       uniplate         >=1.4  && <1.7   default-language:    Haskell2010-  ld-options: -static-  ghc-options: -fPIC+  Other-Modules:+    Paths_homplexity+  -- STATIC: ld-options: -static+  -- STATIC: ghc-options: -fPIC+  if flag(Html)+    CPP-Options:       -DHTML_OUTPUT+    build-depends:     blaze-html   >= 0.9  && < 1,+                       bytestring   >= 0.10 && < 0.11 -test-suite Comments-  main-is:          Comments.hs-  hs-source-dirs:   tests-  other-modules:    TestSource-  type:             exitcode-stdio-1.0-  build-depends:    base             >=4.5  && <4.13,-                    containers       >=0.3  && <0.7,-                    cpphs            >=1.5  && <1.21,-                    deepseq          >=1.3  && <1.7,-                    directory        >=1.1  && <1.4,-                    filepath         >=1.2  && <1.5,-                    uniplate         >=1.4  && <1.7,-                    haskell-src-exts >=1.18 && <1.21,-                    hflags           >=0.3  && <0.5,-                    template-haskell,-                    pqueue,-                    homplexity-  default-language: Haskell2010-  other-extensions: TemplateHaskell++test-suite homplexity-tests+  main-is:             Tests.hs+  hs-source-dirs:      tests+  other-modules:+    Test.Utils+    Test.Utilities+    Test.Metrics.TypeClassComplexitySpec+    Test.Parse.CommentsSpec+    Test.Parse.ExtensionsSpec+  type:                exitcode-stdio-1.0+  build-depends:       base             >=4.5  && <4.16,+                       homplexity,+                       filepath         >=1.2  && <1.5,+                       haskell-src-exts >=1.20 && <1.24,+                       template-haskell >=2.6  && <2.18+  if impl(ghc>=8.8.0)+    build-depends:     hspec            >=2.7.0+  else+    build-depends:     hspec            <2.6.0+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts "-with-rtsopts=-N" 

@@ -3,24 +3,26 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TemplateHaskell       #-} {-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE ViewPatterns          #-} -- | Main module parsing inputs, and running analysis. module Language.Haskell.Homplexity.Assessment where -import Data.Data-import Data.Monoid+import           Data.Data+--import           Data.Monoid -import Language.Haskell.Homplexity.CodeFragment-import Language.Haskell.Homplexity.Cyclomatic-import Language.Haskell.Homplexity.Message-import Language.Haskell.Homplexity.Metric-import Language.Haskell.Homplexity.TypeComplexity+import           Language.Haskell.Homplexity.CodeFragment+import           Language.Haskell.Homplexity.Cyclomatic+import           Language.Haskell.Homplexity.Message+import           Language.Haskell.Homplexity.Metric+import           Language.Haskell.Homplexity.RecordFieldsCount+import           Language.Haskell.Homplexity.TypeClassComplexity+import           Language.Haskell.Homplexity.TypeComplexity -import HFlags+import           HFlags  {- numFunctions = length@@ -76,12 +78,12 @@  assessModuleLength :: Assessment LOC assessModuleLength (fromIntegral -> locs)-                   | locs > flags_moduleLinesWarning  = (Warning,  "should be kept below "        ++-                                                                    show flags_moduleLinesWarning ++-                                                                   " lines of code.")                    | locs > flags_moduleLinesCritical = (Critical, "this function exceeds "       ++                                                                     show flags_moduleLinesCritical ++                                                                    " lines of code.")+                   | locs > flags_moduleLinesWarning  = (Warning,  "should be kept below "        +++                                                                    show flags_moduleLinesWarning +++                                                                   " lines of code.")                    | otherwise    = (Info,     ""                                        )  -- ** Function definition checks@@ -91,12 +93,12 @@  assessFunctionLength :: Assessment LOC assessFunctionLength (fromIntegral -> locs)-                   | locs > flags_functionLinesWarning  = (Warning,  "should be kept below "          ++-                                                                       show flags_functionLinesWarning ++-                                                                      " lines of code.")                    | locs > flags_functionLinesCritical = (Critical, "this function exceeds "          ++                                                                        show flags_functionLinesCritical ++                                                                       " lines of code.")+                   | locs > flags_functionLinesWarning  = (Warning,  "should be kept below "          +++                                                                       show flags_functionLinesWarning +++                                                                      " lines of code.")                    | otherwise                          = (Info,     ""                                 )  @@ -106,12 +108,12 @@  assessFunctionDepth :: Assessment Depth assessFunctionDepth (fromIntegral -> depth)-                    | depth > flags_functionDepthWarning = (Warning, "should have no more than " ++-                                                                      show depth                 ++-                                                                     " nested conditionals"            )-                    | depth > flags_functionDepthWarning = (Warning, "should never exceed " ++-                                                                      show depth            ++-                                                                     " nesting levels for conditionals")+                    | depth > flags_functionDepthCritical = (Critical, "should never exceed " +++                                                                        show depth            +++                                                                       " nesting levels for conditionals")+                    | depth > flags_functionDepthWarning  = (Warning,  "should have no more than " +++                                                                        show depth                 +++                                                                       " nested conditionals"            )                     | otherwise = (Info,    ""                                )  -- *** Cyclomatic complexity of function definition@@ -120,11 +122,11 @@  assessFunctionCC :: Assessment Cyclomatic assessFunctionCC (fromIntegral -> cy)-                 | cy > flags_functionCCWarning  = (Warning, "should be less than "        ++-                                                              show flags_functionCCWarning)-                 | cy > flags_functionCCCritical = (Warning, "must never be as high as " ++-                                                              show flags_functionCCCritical)-                 | otherwise                     = (Info,    ""                               )+                 | cy > flags_functionCCCritical = (Critical, "must never be as high as " +++                                                               show flags_functionCCCritical)+                 | cy > flags_functionCCWarning  = (Warning,  "should be less than "        +++                                                               show flags_functionCCWarning)+                 | otherwise                     = (Info,     ""                               )  -- ** Type signature complexity -- *** Type constructor depth in each type signature@@ -133,11 +135,11 @@  assessTypeConDepth :: Assessment ConDepth assessTypeConDepth (fromIntegral -> cy)-                 | cy > flags_typeConDepthWarning  = (Warning, "should be less than "        ++-                                                                show flags_typeConDepthWarning )-                 | cy > flags_typeConDepthCritical = (Warning, "must never be as high as " ++-                                                                show flags_typeConDepthCritical)-                 | otherwise                       = (Info,    ""                              )+                 | cy > flags_typeConDepthCritical = (Critical, "must never be as high as " +++                                                                 show flags_typeConDepthCritical)+                 | cy > flags_typeConDepthWarning  = (Warning,  "should be less than "        +++                                                                 show flags_typeConDepthWarning )+                 | otherwise                       = (Info,     ""                              )  -- *** Number of function arguments mentioned in each type signature defineFlag "numFunArgsWarning"  (5::Int) "issue warning when number of function arguments exceeds this number"@@ -145,17 +147,56 @@  assessNumFunArgs :: Assessment NumFunArgs assessNumFunArgs (fromIntegral -> cy)-                 | cy > flags_numFunArgsWarning  = (Warning, "should be less than " ++ show flags_numFunArgsWarning )-                 | cy > flags_numFunArgsCritical = (Warning, "must never reach "    ++ show flags_numFunArgsCritical)-                 | otherwise                     = (Info,    ""                                                     )+                 | cy > flags_numFunArgsCritical = (Critical, "must never reach "    ++ show flags_numFunArgsCritical)+                 | cy > flags_numFunArgsWarning  = (Warning,  "should be less than " ++ show flags_numFunArgsWarning )+                 | otherwise                     = (Info,     ""                                                     ) +-- ** Data type complexity+-- *** Record fields count+defineFlag "recordFieldsCountWarning"  (6::Int) "issue warning when combined record fields count exceeds this number"+defineFlag "recordFieldsCountCritical" (9::Int) "issue critical when combined record fields count exceeds this number"++assessRecordFieldsCount :: Assessment RecordFieldsCount+assessRecordFieldsCount (fromIntegral -> cy)+                        | cy > flags_recordFieldsCountCritical = (Critical, "must never reach " ++ show flags_recordFieldsCountCritical  )+                        | cy > flags_recordFieldsCountWarning  = (Warning,  "should be less than " ++ show flags_recordFieldsCountWarning)+                        | otherwise                            = (Info,     ""                                                           )++-- ** Type class complexity+-- *** Method count of type class+defineFlag "typeClassNonTypeDeclWarning"  (5::Int) "issue warning when the number of methods in a type class exceeds this number"+defineFlag "typeClassNonTypeDeclCritical" (7::Int) "issue critical when the number of methods in a type class exceeds this number"++assessTCNonTypeDeclCount :: Assessment NonTypeDeclCount+assessTCNonTypeDeclCount (fromIntegral -> mc)+  | mc > flags_typeClassNonTypeDeclCritical = (Critical, "should never have more than " +++                                              show flags_typeClassNonTypeDeclCritical)+  | mc > flags_typeClassNonTypeDeclWarning  = (Warning,  " should have no more than " +++                                              show flags_typeClassNonTypeDeclWarning)+  | otherwise = (Info, "")++-- *** Associated type count of type class+defineFlag "typeClassAssocTypesWarning"  (3::Int) "issue warning when the number of associated types in a type class exceeds this number"+defineFlag "typeClassAssocTypesCritical" (5::Int) "issue critical when the number of associated types in a type class exceeds this number"++assessTCAssocTypesCount :: Assessment AssocTypeCount+assessTCAssocTypesCount (fromIntegral -> atc)+  | atc > flags_typeClassAssocTypesCritical = (Critical, "should never have more than " +++                                              show flags_typeClassAssocTypesCritical)+  | atc > flags_typeClassAssocTypesWarning  = (Warning,  " should have no more than " +++                                              show flags_typeClassAssocTypesWarning)+  | otherwise                               = (Info, "")+ -- * Computing and assessing @Metric@s for all @CodeFragment@. -- | Compute all metrics, and assign severity depending on configured thresholds. metrics :: [Program -> Log]-metrics  = [measureTopOccurs assessModuleLength   locT        moduleT-           ,measureTopOccurs assessFunctionLength locT        functionT-           ,measureTopOccurs assessFunctionDepth  depthT      functionT-           ,measureTopOccurs assessFunctionCC     cyclomaticT functionT-           ,measureTopOccurs assessTypeConDepth   conDepthT   typeSignatureT-           ,measureTopOccurs assessNumFunArgs     numFunArgsT typeSignatureT]-+metrics  = [ measureTopOccurs assessModuleLength       locT               moduleT+           , measureTopOccurs assessFunctionLength     locT               functionT+           , measureTopOccurs assessFunctionDepth      depthT             functionT+           , measureTopOccurs assessFunctionCC         cyclomaticT        functionT+           , measureTopOccurs assessTypeConDepth       conDepthT          typeSignatureT+           , measureTopOccurs assessNumFunArgs         numFunArgsT        typeSignatureT+           , measureTopOccurs assessRecordFieldsCount  recordFieldsCountT dataDefT+           , measureTopOccurs assessTCNonTypeDeclCount nonTypeDeclCountT  typeClassT+           , measureTopOccurs assessTCAssocTypesCount  assocTypeCountT    typeClassT+           ]

@@ -0,0 +1,213 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE NamedFieldPuns      #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Language.Haskell.Homplexity.CabalFiles+    ( CabalFile+    , CabalPackage(..)+    , warnings+    , parseCabalFile+    , languageExtensions+    ) where+++import Data.Generics.Uniplate.Data as U+import Data.String (fromString)+import Language.Haskell.Extension as Cabal+import Language.Haskell.Exts.Extension as HSE+import Language.Haskell.Exts.SrcLoc+import qualified Data.ByteString as BS++import Language.Haskell.Homplexity.Message++#if MIN_VERSION_Cabal(3,0,0)+import Distribution.PackageDescription.Parsec+import Distribution.Parsec.Warning+import Distribution.Types.GenericPackageDescription+#elif MIN_VERSION_Cabal(2,0,0)+import Distribution.PackageDescription.Parsec+import Distribution.Types.GenericPackageDescription+import Distribution.Parsec.Common+#else+import Distribution.PackageDescription(GenericPackageDescription(..))+import Distribution.PackageDescription.Parse(parsePackageDescription)+import Distribution.ParseUtils++parseGenericPackageDescription = parsePackageDescription . BS.unpack+#endif++++-- | Project file cabal file related info+--+data CabalFile = CabalFile+    { warnings    :: [PWarning]+    , description :: GenericPackageDescription+    }+    deriving (Show)+++parseCabalFile :: FilePath -> IO (Either Log CabalFile)+parseCabalFile cabalFilePath = do+    cabalFile <- BS.readFile cabalFilePath+    case runParseResult $ parseGenericPackageDescription cabalFile of+        (_, Left err) ->+            return $ Left $ critical (SrcLoc cabalFilePath 0 0) (show err)+        (warns, Right desc) ->+            return $ Right $ CabalFile warns desc+++cabalExtensionToHseExtension :: Cabal.Extension -> HSE.Extension+cabalExtensionToHseExtension (Cabal.UnknownExtension ex) = HSE.UnknownExtension ex+cabalExtensionToHseExtension (Cabal.EnableExtension ex)  = HSE.EnableExtension (cabalKnownExtensionToHseKnownExtension ex)+cabalExtensionToHseExtension (Cabal.DisableExtension ex) = HSE.DisableExtension (cabalKnownExtensionToHseKnownExtension ex)+++cabalKnownExtensionToHseKnownExtension :: Cabal.KnownExtension -> HSE.KnownExtension+cabalKnownExtensionToHseKnownExtension Cabal.OverlappingInstances = HSE.OverlappingInstances+-- cabalKnownExtensionToHseKnownExtension Cabal.AllowAmbiguousTypes = HSE.AllowAmbiguousTypes+-- cabalKnownExtensionToHseKnownExtension Cabal.ApplicativeDo = HSE.ApplicativeDo+cabalKnownExtensionToHseKnownExtension Cabal.Arrows = HSE.Arrows+-- cabalKnownExtensionToHseKnownExtension Cabal.AutoDeriveTypeable = HSE.AutoDeriveTypeable+cabalKnownExtensionToHseKnownExtension Cabal.BangPatterns = HSE.BangPatterns+cabalKnownExtensionToHseKnownExtension Cabal.BinaryLiterals = HSE.BinaryLiterals+-- cabalKnownExtensionToHseKnownExtension Cabal.BlockArguments = HSE.BlockArguments+cabalKnownExtensionToHseKnownExtension Cabal.CApiFFI = HSE.CApiFFI+cabalKnownExtensionToHseKnownExtension Cabal.CPP = HSE.CPP+cabalKnownExtensionToHseKnownExtension Cabal.ConstrainedClassMethods = HSE.ConstrainedClassMethods+cabalKnownExtensionToHseKnownExtension Cabal.ConstraintKinds = HSE.ConstraintKinds+cabalKnownExtensionToHseKnownExtension Cabal.DataKinds = HSE.DataKinds+cabalKnownExtensionToHseKnownExtension Cabal.DatatypeContexts = HSE.DatatypeContexts+cabalKnownExtensionToHseKnownExtension Cabal.DefaultSignatures = HSE.DefaultSignatures+cabalKnownExtensionToHseKnownExtension Cabal.DeriveDataTypeable = HSE.DeriveDataTypeable+cabalKnownExtensionToHseKnownExtension Cabal.DeriveFoldable = HSE.DeriveFoldable+cabalKnownExtensionToHseKnownExtension Cabal.DeriveFunctor = HSE.DeriveFunctor+cabalKnownExtensionToHseKnownExtension Cabal.DeriveGeneric = HSE.DeriveGeneric+-- cabalKnownExtensionToHseKnownExtension Cabal.DeriveLift = HSE.DeriveLift+cabalKnownExtensionToHseKnownExtension Cabal.DeriveTraversable = HSE.DeriveTraversable+cabalKnownExtensionToHseKnownExtension Cabal.DisambiguateRecordFields = HSE.DisambiguateRecordFields+cabalKnownExtensionToHseKnownExtension Cabal.DoAndIfThenElse = HSE.DoAndIfThenElse+cabalKnownExtensionToHseKnownExtension Cabal.DoRec = HSE.DoRec+-- cabalKnownExtensionToHseKnownExtension Cabal.DuplicateRecordFields = HSE.DuplicateRecordFields+cabalKnownExtensionToHseKnownExtension Cabal.EmptyDataDecls = HSE.EmptyDataDecls+cabalKnownExtensionToHseKnownExtension Cabal.ExistentialQuantification = HSE.ExistentialQuantification+cabalKnownExtensionToHseKnownExtension Cabal.ExplicitForAll = HSE.ExplicitForAll+cabalKnownExtensionToHseKnownExtension Cabal.ExplicitNamespaces = HSE.ExplicitNamespaces+cabalKnownExtensionToHseKnownExtension Cabal.ExtendedDefaultRules = HSE.ExtendedDefaultRules+cabalKnownExtensionToHseKnownExtension Cabal.ExtensibleRecords = HSE.ExtensibleRecords+cabalKnownExtensionToHseKnownExtension Cabal.FlexibleContexts = HSE.FlexibleContexts+cabalKnownExtensionToHseKnownExtension Cabal.FlexibleInstances = HSE.FlexibleInstances+cabalKnownExtensionToHseKnownExtension Cabal.ForeignFunctionInterface = HSE.ForeignFunctionInterface+cabalKnownExtensionToHseKnownExtension Cabal.FunctionalDependencies = HSE.FunctionalDependencies+-- cabalKnownExtensionToHseKnownExtension Cabal.GADTSyntax = HSE.GADTSyntax+cabalKnownExtensionToHseKnownExtension Cabal.GADTs = HSE.GADTs+cabalKnownExtensionToHseKnownExtension Cabal.GHCForeignImportPrim = HSE.GHCForeignImportPrim+cabalKnownExtensionToHseKnownExtension Cabal.GeneralizedNewtypeDeriving = HSE.GeneralizedNewtypeDeriving+cabalKnownExtensionToHseKnownExtension Cabal.Generics = HSE.Generics+cabalKnownExtensionToHseKnownExtension Cabal.HereDocuments = HSE.HereDocuments+-- cabalKnownExtensionToHseKnownExtension Cabal.HexFloatLiterals = HSE.HexFloatLiterals+cabalKnownExtensionToHseKnownExtension Cabal.ImplicitParams = HSE.ImplicitParams+cabalKnownExtensionToHseKnownExtension Cabal.ImplicitPrelude = HSE.ImplicitPrelude+cabalKnownExtensionToHseKnownExtension Cabal.ImpredicativeTypes = HSE.ImpredicativeTypes+cabalKnownExtensionToHseKnownExtension Cabal.IncoherentInstances = HSE.IncoherentInstances+cabalKnownExtensionToHseKnownExtension Cabal.InstanceSigs = HSE.InstanceSigs+cabalKnownExtensionToHseKnownExtension Cabal.InterruptibleFFI = HSE.InterruptibleFFI+cabalKnownExtensionToHseKnownExtension Cabal.KindSignatures = HSE.KindSignatures+cabalKnownExtensionToHseKnownExtension Cabal.LambdaCase = HSE.LambdaCase+cabalKnownExtensionToHseKnownExtension Cabal.LiberalTypeSynonyms = HSE.LiberalTypeSynonyms+cabalKnownExtensionToHseKnownExtension Cabal.MagicHash = HSE.MagicHash+-- cabalKnownExtensionToHseKnownExtension Cabal.MonadComprehensions = HSE.MonadComprehensions+-- cabalKnownExtensionToHseKnownExtension Cabal.MonadFailDesugaring = HSE.MonadFailDesugaring+cabalKnownExtensionToHseKnownExtension Cabal.MonoLocalBinds = HSE.MonoLocalBinds+cabalKnownExtensionToHseKnownExtension Cabal.MonoPatBinds = HSE.MonoPatBinds+cabalKnownExtensionToHseKnownExtension Cabal.MonomorphismRestriction = HSE.MonomorphismRestriction+cabalKnownExtensionToHseKnownExtension Cabal.MultiParamTypeClasses = HSE.MultiParamTypeClasses+cabalKnownExtensionToHseKnownExtension Cabal.MultiWayIf = HSE.MultiWayIf+cabalKnownExtensionToHseKnownExtension Cabal.NPlusKPatterns = HSE.NPlusKPatterns+cabalKnownExtensionToHseKnownExtension Cabal.NamedFieldPuns = HSE.NamedFieldPuns+cabalKnownExtensionToHseKnownExtension Cabal.NamedWildCards = HSE.NamedWildCards+-- cabalKnownExtensionToHseKnownExtension Cabal.NegativeLiterals = HSE.NegativeLiterals+cabalKnownExtensionToHseKnownExtension Cabal.NewQualifiedOperators = HSE.NewQualifiedOperators+cabalKnownExtensionToHseKnownExtension Cabal.NondecreasingIndentation = HSE.NondecreasingIndentation+-- cabalKnownExtensionToHseKnownExtension Cabal.NullaryTypeClasses = HSE.NullaryTypeClasses+-- cabalKnownExtensionToHseKnownExtension Cabal.NumDecimals = HSE.NumDecimals+-- cabalKnownExtensionToHseKnownExtension Cabal.NumericUnderscores = HSE.NumericUnderscores+-- cabalKnownExtensionToHseKnownExtension Cabal.OverlappingInstances = HSE.OverlappingInstances+cabalKnownExtensionToHseKnownExtension Cabal.OverloadedLabels = HSE.OverloadedLabels+-- cabalKnownExtensionToHseKnownExtension Cabal.OverloadedLists = HSE.OverloadedLists+cabalKnownExtensionToHseKnownExtension Cabal.OverloadedStrings = HSE.OverloadedStrings+cabalKnownExtensionToHseKnownExtension Cabal.PackageImports = HSE.PackageImports+cabalKnownExtensionToHseKnownExtension Cabal.ParallelArrays = HSE.ParallelArrays+cabalKnownExtensionToHseKnownExtension Cabal.ParallelListComp = HSE.ParallelListComp+cabalKnownExtensionToHseKnownExtension Cabal.PartialTypeSignatures = HSE.PartialTypeSignatures+cabalKnownExtensionToHseKnownExtension Cabal.PatternGuards = HSE.PatternGuards+cabalKnownExtensionToHseKnownExtension Cabal.PatternSignatures = HSE.PatternSignatures+cabalKnownExtensionToHseKnownExtension Cabal.PatternSynonyms = HSE.PatternSynonyms+cabalKnownExtensionToHseKnownExtension Cabal.PolyKinds = HSE.PolyKinds+cabalKnownExtensionToHseKnownExtension Cabal.PolymorphicComponents = HSE.PolymorphicComponents+cabalKnownExtensionToHseKnownExtension Cabal.PostfixOperators = HSE.PostfixOperators+-- cabalKnownExtensionToHseKnownExtension Cabal.QuantifiedConstraints = HSE.QuantifiedConstraints+cabalKnownExtensionToHseKnownExtension Cabal.QuasiQuotes = HSE.QuasiQuotes+cabalKnownExtensionToHseKnownExtension Cabal.Rank2Types = HSE.Rank2Types+cabalKnownExtensionToHseKnownExtension Cabal.RankNTypes = HSE.RankNTypes+cabalKnownExtensionToHseKnownExtension Cabal.RebindableSyntax = HSE.RebindableSyntax+cabalKnownExtensionToHseKnownExtension Cabal.RecordPuns = HSE.RecordPuns+cabalKnownExtensionToHseKnownExtension Cabal.RecordWildCards = HSE.RecordWildCards+cabalKnownExtensionToHseKnownExtension Cabal.RecursiveDo = HSE.RecursiveDo+cabalKnownExtensionToHseKnownExtension Cabal.RegularPatterns = HSE.RegularPatterns+cabalKnownExtensionToHseKnownExtension Cabal.RelaxedPolyRec = HSE.RelaxedPolyRec+cabalKnownExtensionToHseKnownExtension Cabal.RestrictedTypeSynonyms = HSE.RestrictedTypeSynonyms+cabalKnownExtensionToHseKnownExtension Cabal.RoleAnnotations = HSE.RoleAnnotations+cabalKnownExtensionToHseKnownExtension Cabal.Safe = HSE.Safe+cabalKnownExtensionToHseKnownExtension Cabal.SafeImports = HSE.SafeImports+cabalKnownExtensionToHseKnownExtension Cabal.ScopedTypeVariables = HSE.ScopedTypeVariables+cabalKnownExtensionToHseKnownExtension Cabal.StandaloneDeriving = HSE.StandaloneDeriving+-- cabalKnownExtensionToHseKnownExtension Cabal.StarIsType = HSE.StarIsType+-- cabalKnownExtensionToHseKnownExtension Cabal.StaticPointers = HSE.StaticPointers+-- cabalKnownExtensionToHseKnownExtension Cabal.Strict = HSE.Strict+-- cabalKnownExtensionToHseKnownExtension Cabal.StrictData = HSE.StrictData+cabalKnownExtensionToHseKnownExtension Cabal.TemplateHaskell = HSE.TemplateHaskell+-- cabalKnownExtensionToHseKnownExtension Cabal.TemplateHaskellQuotes = HSE.TemplateHaskellQuotes+-- cabalKnownExtensionToHseKnownExtension Cabal.TraditionalRecordSyntax = HSE.TraditionalRecordSyntax+cabalKnownExtensionToHseKnownExtension Cabal.TransformListComp = HSE.TransformListComp+cabalKnownExtensionToHseKnownExtension Cabal.Trustworthy = HSE.Trustworthy+cabalKnownExtensionToHseKnownExtension Cabal.TupleSections = HSE.TupleSections+cabalKnownExtensionToHseKnownExtension Cabal.TypeApplications = HSE.TypeApplications+cabalKnownExtensionToHseKnownExtension Cabal.TypeFamilies = HSE.TypeFamilies+-- cabalKnownExtensionToHseKnownExtension Cabal.TypeInType = HSE.TypeInType+cabalKnownExtensionToHseKnownExtension Cabal.TypeOperators = HSE.TypeOperators+cabalKnownExtensionToHseKnownExtension Cabal.TypeSynonymInstances = HSE.TypeSynonymInstances+cabalKnownExtensionToHseKnownExtension Cabal.UnboxedTuples = HSE.UnboxedTuples+cabalKnownExtensionToHseKnownExtension Cabal.UndecidableInstances = HSE.UndecidableInstances+-- cabalKnownExtensionToHseKnownExtension Cabal.UndecidableSuperClasses = HSE.UndecidableSuperClasses+cabalKnownExtensionToHseKnownExtension Cabal.UnicodeSyntax = HSE.UnicodeSyntax+cabalKnownExtensionToHseKnownExtension Cabal.UnliftedFFITypes = HSE.UnliftedFFITypes+-- cabalKnownExtensionToHseKnownExtension Cabal.Unsafe = HSE.Unsafe+cabalKnownExtensionToHseKnownExtension Cabal.ViewPatterns = HSE.ViewPatterns+cabalKnownExtensionToHseKnownExtension Cabal.XmlSyntax = HSE.XmlSyntax+cabalKnownExtensionToHseKnownExtension Cabal.DeriveAnyClass = HSE.DeriveAnyClass+cabalKnownExtensionToHseKnownExtension Cabal.DerivingStrategies = HSE.DerivingStrategies+cabalKnownExtensionToHseKnownExtension Cabal.EmptyCase = HSE.EmptyCase+cabalKnownExtensionToHseKnownExtension Cabal.JavaScriptFFI = HSE.JavaScriptFFI+cabalKnownExtensionToHseKnownExtension Cabal.TypeFamilyDependencies = HSE.TypeFamilyDependencies+cabalKnownExtensionToHseKnownExtension Cabal.UnboxedSums = HSE.UnboxedSums++cabalKnownExtensionToHseKnownExtension ex = error $ "Extension '" ++ show ex ++ "' unsupported"+++-- | Cabal package identification+--+data CabalPackage = Library | Package String+++languageExtensions :: CabalPackage -> CabalFile -> [HSE.Extension]+languageExtensions moduleName CabalFile{description} = map cabalExtensionToHseExtension $ languageExtensions' moduleName+  where+    languageExtensions' Library = [e | (e :: Cabal.Extension) <- U.universeBi (condLibrary description)]+    languageExtensions' (Package pname) =+        let pname' = fromString pname+            filt = filter (\(name,_) -> name == pname')+        in [e | (e :: Cabal.Extension) <- U.universeBi (filt $ condForeignLibs description)] +++           [e | (e :: Cabal.Extension) <- U.universeBi (filt $ condExecutables description)] +++           [e | (e :: Cabal.Extension) <- U.universeBi (filt $ condTestSuites description) ] +++           [e | (e :: Cabal.Extension) <- U.universeBi (filt $ condBenchmarks description) ]+

@@ -6,8 +6,8 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE ViewPatterns          #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-} -- | This module generalizes over types of code fragments -- that may need to be iterated upon and measured separately. module Language.Haskell.Homplexity.CodeFragment (@@ -23,21 +23,26 @@   , moduleT   , Function       (..)   , functionT+  , DataDef       (..)+  , dataDefT   , TypeSignature  (..)   , typeSignatureT+  , TypeClass (..)+  , typeClassT   , fragmentLoc   -- TODO: add ClassSignature   ) where -import Data.Data-import Data.Functor-import Data.Generics.Uniplate.Data-import Data.List-import Data.Maybe-import Data.Monoid-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Homplexity.SrcSlice+import           Data.Data+--import           Data.Functor+import           Data.Generics.Uniplate.Data+import           Data.List+import           Data.Maybe+--import           Data.Monoid+import           Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Homplexity.SrcSlice+import           Language.Haskell.Homplexity.Utilities  -- | Program newtype Program = Program { allModules :: [Module SrcLoc] }@@ -65,6 +70,17 @@ functionT :: Proxy Function functionT  = Proxy +-- | Alias for a @data@ declaration+data DataDef = DataDef {+                 dataDefName  :: String+               , dataDefCtors :: Either [QualConDecl SrcLoc] [GadtDecl SrcLoc]+               }+  deriving (Data, Typeable, Show)++-- | Proxy for passing @DataDef@ type as an argument.+dataDefT :: Proxy DataDef+dataDefT  = Proxy+ -- ** Type signature of a function -- | Type alias for a type signature of a function as a @CodeFragment@ data TypeSignature = TypeSignature { loc         :: SrcLoc@@ -72,15 +88,21 @@                                    , theType     ::  Type SrcLoc }   deriving (Data, Typeable, Show) --- | Proxy for passing @Program@ type as an argument.+-- | Proxy for passing @TypeSignature@ type as an argument. typeSignatureT :: Proxy TypeSignature typeSignatureT  = Proxy  -- ** TODO: class signatures (number of function decls inside) -- | Alias for a class signature-data ClassSignature = ClassSignature-  deriving (Data, Typeable)+data TypeClass = TypeClass { tcName  :: String+                           , tcDecls :: Maybe [ClassDecl SrcLoc]+                           }+  deriving (Data, Typeable, Show) +-- | Proxy for passing @TypeClass@ type as an argument.+typeClassT :: Proxy TypeClass+typeClassT  = Proxy+ -- TODO: need combination of Fold and Biplate -- Resulting record may be created to make pa @@ -105,8 +127,6 @@ fragmentLoc =  getPointLoc             .  fragmentSlice -mergeBinds = catMaybes- instance CodeFragment Function where   type AST Function            = Decl SrcLoc   matchAST (FunBind _ matches) = Just@@ -131,6 +151,17 @@   matchAST _                                          = Nothing   fragmentName Function {..} = unwords $ "function":functionNames +instance CodeFragment DataDef where+  type AST DataDef = Decl SrcLoc+  matchAST (DataDecl _ _ _ declHead qualConDecls _) = do+    name <- listToMaybe (universeBi declHead :: [Name SrcLoc])+    pure DataDef { dataDefName = unName name, dataDefCtors = Left qualConDecls }+  matchAST (GDataDecl _ _ _ declHead _ gadtDecls _) = do+    name <- listToMaybe (universeBi declHead :: [Name SrcLoc])+    pure DataDef { dataDefName = unName name, dataDefCtors = Right gadtDecls }+  matchAST _ = Nothing+  fragmentName DataDef {..} = "data " ++ dataDefName+ -- | Make a single element list. singleton :: a -> [a] singleton  = (:[])@@ -157,10 +188,10 @@  instance CodeFragment (Module SrcLoc) where   type AST (Module SrcLoc)= Module SrcLoc-  matchAST = Just -  fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) = +  matchAST = Just+  fragmentName (Module _ (Just (ModuleHead _ (ModuleName _ theName) _ _)) _ _ _) =                 "module " ++ theName-  fragmentName (Module _  Nothing                                         _ _ _) = +  fragmentName (Module _  Nothing                                         _ _ _) =                 "<unnamed module>"   fragmentName (XmlPage   _ (ModuleName _ theName) _ _ _ _ _)            = "XML page " ++ theName   fragmentName (XmlHybrid _ (Just (ModuleHead _ (ModuleName _ theName) _ _))@@ -178,8 +209,16 @@   fragmentName TypeSignature {..} = "type signature for "                                  ++ intercalate ", " (map unName identifiers) +instance CodeFragment TypeClass where+  type AST TypeClass = Decl SrcLoc++  matchAST (ClassDecl _ _ declHead _ classDecls)+    = Just $ TypeClass (unName . declHeadName $ declHead) classDecls+  matchAST _ = Nothing++  fragmentName (TypeClass tcName _) = "type class " ++ tcName+ -- | Unpack @Name@ identifier into a @String@. unName :: Name a -> String unName (Symbol _ s) = s-unName (Ident  _ i) = i -+unName (Ident  _ i) = i

@@ -9,7 +9,7 @@     CommentLink      (..)   , CommentType      (..)   , classifyComments-  , findCommentType -- exposed for testing only+  , findCommentType  -- exposed for testing only   , CommentSite      (..)   , commentable @@ -22,7 +22,6 @@ import Data.Functor import Data.List import qualified Data.Map.Strict as Map-import qualified Data.PQueue.Max as Prio  import Language.Haskell.Homplexity.CodeFragment import Language.Haskell.Homplexity.SrcSlice@@ -67,13 +66,13 @@   deriving (Eq, Show)  compareStarts :: CommentSite -> CommentSite -> Ordering-compareStarts = compare `on` start . siteSlice+compareStarts = on compare (start . siteSlice)  instance Ord Ends   where-  compare = compareEnds `on` siteEnded+  compare = on compareEnds siteEnded  compareEnds :: CommentSite -> CommentSite -> Ordering-compareEnds  = compare `on` end   . siteSlice+compareEnds  = on compare (end   . siteSlice)  start, end :: SrcSlice -> (Int, Int) start slice = (srcSpanStartColumn slice, srcSpanStartLine slice)

@@ -18,6 +18,7 @@ import Language.Haskell.Exts.Syntax import Language.Haskell.Homplexity.CodeFragment import Language.Haskell.Homplexity.Metric+import Language.Haskell.Homplexity.Utilities  type MatchSet = [Match SrcLoc] @@ -43,10 +44,6 @@              + cyclomaticOfExprs   x              + 1 --- | Sum the results of mapping the function over the list.-sumOf :: (a -> Int) -> [a] -> Int-sumOf f = sum . map f- -- | Compute cyclomatic complexity of pattern matches. cyclomaticOfMatches :: Data from => from -> Int cyclomaticOfMatches  = sumOf recurse . childrenBi@@ -66,10 +63,6 @@     armCount _              = 0               -- others are ignored  -- * Decision depth--- | Sum the results of mapping the function over the list.-maxOf :: (a -> Int) -> [a] -> Int-maxOf f = maximum . (0:). map f- -- | Decision depth newtype Depth = Depth Int   deriving (Eq, Ord, Enum, Num, Real, Integral)

@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns               #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RecordWildCards            #-} {-# LANGUAGE TemplateHaskell            #-} -- | Classifying messages by severity and filtering them.@@ -17,18 +18,25 @@   , extract   ) where -import Control.Arrow-import Control.DeepSeq-import Data.Function                                        (on)-import Data.Foldable                            as Foldable-import Data.Monoid+import           Control.Arrow+import           Control.DeepSeq+import           Data.Foldable                      as Foldable+import           Data.Function                      (on) #if __GLASGOW_HASKELL__ >= 800-import Data.Semigroup+import           Data.Semigroup                     (Semigroup (..))+#else+import           Data.Monoid #endif-import Data.Sequence                            as Seq-import Language.Haskell.Exts-import Language.Haskell.TH.Syntax                           (Lift(..))-import HFlags+import           Data.Sequence                      as Seq+import           HFlags+import           Language.Haskell.Exts              hiding (style)+import           Language.Haskell.TH.Syntax         (Lift (..))+#ifdef HTML_OUTPUT+import           Prelude                            hiding (div, head, id, span)+import           Text.Blaze.Html4.Strict            hiding (map, style)+import           Text.Blaze.Html4.Strict.Attributes hiding (span, title)+--import           Text.Blaze.Renderer.Utf8           (renderMarkup)+#endif  -- | Keeps a set of messages newtype Log = Log { unLog :: Seq Message }@@ -49,10 +57,9 @@   deriving (Eq)  instance NFData Message where-  rnf Message {..} = rnf msgSeverity `seq` rnf msgText `seq` rnf msgSrc--instance NFData SrcLoc where-  rnf SrcLoc {..} = rnf srcFilename `seq` rnf srcLine `seq` rnf srcColumn+  rnf Message {msgSrc=SrcLoc{..},..} =+    rnf msgSeverity `seq` rnf msgText `seq`+    rnf srcFilename `seq` rnf srcLine `seq` rnf srcColumn  instance Show Message where   showsPrec _ Message {msgSrc=loc@SrcLoc{..}, ..} = shows msgSeverity@@ -62,10 +69,33 @@                                                   . shows loc                                                   -- . shows srcLine                                                   -- . shows srcColumn-                                                  . (':':)+                                                  . (": "++)                                                   . (msgText++)                                                   . ('\n':) +#ifdef HTML_OUTPUT+instance ToMarkup Message where+  toMarkup Message {msgSrc=SrcLoc{..}, ..} =+    p ! classId $+     (toMarkup msgSeverity+       <> string ": "+       <> (a ! href (toValue srcFilename) $ (string srcFilename))+       <> string ": "+       <> string msgText)+    where+      classId = case msgSeverity of+                     Debug    -> class_ "debug"+                     Info     -> class_ "info"+                     Warning  -> class_ "warning"+                     Critical -> class_ "critical"++instance ToMarkup Severity where+  toMarkup Debug    = span   ! class_ "severity" $ string (show Debug)+  toMarkup Info     = span   ! class_ "severity" $ string (show Info)+  toMarkup Warning  = strong ! class_ "severity" $ string (show Warning)+  toMarkup Critical = strong ! class_ "severity" $ string (show Critical)+#endif+ -- | Message severity data Severity = Debug               | Info@@ -93,7 +123,7 @@ message ::  Severity -> SrcLoc -> String -> Log message msgSeverity msgSrc msgText = Log $ Seq.singleton Message {..} --- | TODO: automatic inference of the srcLine +-- | TODO: automatic inference of the srcLine -- | Log a certain error critical :: SrcLoc -> String -> Log critical  = message Critical@@ -127,4 +157,3 @@ instance Show Log where   showsPrec _ l e = Foldable.foldr  shows e $                     orderedMessages Debug l-

@@ -1,8 +1,8 @@-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Class for defining code metrics, and its simplest implementation - number of lines of code. +-- | Class for defining code metrics, and its simplest implementation - number of lines of code. module Language.Haskell.Homplexity.Metric (     Metric (..)   , LOC@@ -11,16 +11,16 @@   , measureFor   ) where -import Data.Data-import Data.Function-import Data.Functor-import Data.Generics.Uniplate.Data-import Data.List-import Control.Arrow-import Language.Haskell.Exts.SrcLoc+import           Data.Data+import           Data.Function+--import Data.Functor+import           Control.Arrow+import           Data.Generics.Uniplate.Data+import           Data.List+import           Language.Haskell.Exts.SrcLoc --import Language.Haskell.Exts.Syntax -import Language.Haskell.Homplexity.CodeFragment+import           Language.Haskell.Homplexity.CodeFragment  -- | Metric can be computed on a set of @CodeFragment@ fragments -- and then shown.@@ -29,7 +29,7 @@  -- | Number of lines of code -- (example metric)-newtype LOC = LOC { asInt :: Int }+newtype LOC = LOC { _asInt :: Int }   deriving (Ord, Eq, Enum, Num, Real, Integral)  -- | Proxy for passing @LOC@ type as parameter.

@@ -1,34 +1,28 @@ {-# LANGUAGE CPP                   #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE UndecidableInstances  #-} -- | Parsing of Haskell source files, and error reporting for unparsable files. module Language.Haskell.Homplexity.Parse (parseSource, parseTest) where -import Control.Exception as E-import Data.Functor+import           Control.Exception                    as E+--import Data.Functor+--import Data.Maybe+import           Data.Map.Strict                      (Map)+import qualified Data.Map.Strict                      as Map -import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts-import Language.Haskell.Homplexity.Comments-import Language.Haskell.Homplexity.Message-import Language.Preprocessor.Cpphs+import           Language.Haskell.Exts+--import           Language.Haskell.Exts.SrcLoc+--import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Homplexity.Comments+import           Language.Haskell.Homplexity.Message+import           Language.Preprocessor.Cpphs  --import HFlags --- | Maximally permissive list of language extensions.-myExtensions ::  [Extension]-myExtensions = EnableExtension `map`-               [RecordWildCards,-                ScopedTypeVariables, CPP, MultiParamTypeClasses, TemplateHaskell,  RankNTypes, UndecidableInstances,-                FlexibleContexts, KindSignatures, EmptyDataDecls, BangPatterns, ForeignFunctionInterface,-                Generics, MagicHash, ViewPatterns, PatternGuards, TypeOperators, GADTs, PackageImports,-                MultiWayIf, SafeImports, ConstraintKinds, TypeFamilies, IncoherentInstances, FunctionalDependencies,-                ExistentialQuantification, ImplicitParams, UnicodeSyntax,-                LambdaCase, TupleSections, NamedFieldPuns]  -- | CppHs options that should be compatible with haskell-src-exts cppHsOptions ::  CpphsOptions@@ -43,46 +37,70 @@                             }                } --- | For use in test suite-parseTest ::  String -> String -> IO (Module SrcLoc, [CommentLink])-parseTest testId testSource = do-  maybeParsed <- parseModuleWithComments (makeParseMode testId)-                                      <$> runCpphs cppHsOptions testId testSource-  case maybeParsed of-    ParseOk (parsed, comments) -> return $ (getPointLoc <$> parsed, classifyComments comments)-    other                      -> error $ show other +-- | Removes duplicate and switching extensions.+--+--   Example:+--+--   >>> [ EnableExtension ScopedTypeVariables, DisableExtension ScopedTypeVariables, EnableExtension DoRec ]+--   [ DisableExtension ScopedTypeVariables, EnableExtension DoRec ]+--+collapseSameExtensions :: [Extension] -> [Extension]+collapseSameExtensions = mkList . foldl processExtension Map.empty+  where+    processExtension :: Map KnownExtension Bool -> Extension -> Map KnownExtension Bool+    processExtension m (UnknownExtension _) = m+    processExtension m (EnableExtension  e) = Map.insert e True  m+    processExtension m (DisableExtension e) = Map.insert e False m+    mkList = map (\case (e, True)  -> EnableExtension e+                        (e, False) -> DisableExtension e+                 )+             . Map.toList+++mkParseMode :: FilePath -> [Extension] -> ParseMode+mkParseMode inputFilename extensions = ParseMode+    { parseFilename         = inputFilename+    , baseLanguage          = Haskell2010+    , extensions            = extensions+    , ignoreLanguagePragmas = False+    , ignoreLinePragmas     = False+    , fixities              = Just preludeFixities+    , ignoreFunctionArity   = False+    }+++parseSourceInternal :: [Extension] -> FilePath -> String -> IO (ParseResult (Module SrcSpanInfo, [Comment]))+parseSourceInternal additionalExtensions inputFilename inputFileContents = do+    deCppHsInput <- runCpphs cppHsOptions inputFilename inputFileContents+    let fileExtensions = maybe [] snd $ readExtensions deCppHsInput+        extensions     = collapseSameExtensions (additionalExtensions ++ fileExtensions)+        result         = parseModuleWithComments (mkParseMode inputFilename extensions) deCppHsInput+    return result++ -- | Parse Haskell source file, using CppHs for preprocessing, -- and haskell-src-exts for parsing. -- -- Catches all exceptions and wraps them as @Critical@ log messages.-parseSource ::  FilePath -> IO (Either Log (Module SrcLoc, [CommentLink]))-parseSource inputFilename = do-  parseResult <- (do-    input   <- readFile inputFilename-    result  <- parseModuleWithComments (makeParseMode inputFilename)-                                    <$> runCpphs cppHsOptions inputFilename input-    evaluate result)+parseSource :: [Extension] -> FilePath -> IO (Either Log (Module SrcLoc, [CommentLink]))+parseSource additionalExtensions inputFilename = do+  parseResult <- (    readFile inputFilename+                  >>= parseSourceInternal additionalExtensions inputFilename+                  >>= evaluate)       `E.catch` handleException (ParseFailed thisFileLoc)   case parseResult of-    ParseOk (parsed, comments) -> do {-putStrLn   "ORDERED:"-                                     putStrLn $ unlines $ map show-                                              $ orderCommentsAndCommentables (commentable      parsed  )-                                                                             (classifyComments comments) -}-                                     return   $ Right (getPointLoc <$> parsed,-                                                       classifyComments comments) -    ParseFailed aLoc msg       ->    return   $ Left $ critical aLoc msg+    ParseOk (parsed, comments) -> return $ Right (getPointLoc <$> parsed,+                                                  classifyComments comments)+    ParseFailed aLoc msg       -> return $ Left $ critical aLoc msg   where     handleException helper (e :: SomeException) = return $ helper $ show e     thisFileLoc = noLoc { srcFilename = inputFilename } -makeParseMode inputFilename =-  ParseMode {-    parseFilename         = inputFilename-  , baseLanguage          = Haskell2010-  , extensions            = myExtensions-  , ignoreLanguagePragmas = False-  , ignoreLinePragmas     = False-  , fixities              = Just preludeFixities-  , ignoreFunctionArity   = False-  }++-- | For use in test suite+parseTest ::  String -> String -> IO (Module SrcLoc, [CommentLink])+parseTest testId testSource = do+    parseSourceInternal [] testId testSource >>= \case+        ParseOk (parsed, comments) -> return $ (getPointLoc <$> parsed, classifyComments comments)+        other                      -> error $ show other

@@ -0,0 +1,49 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UndecidableInstances       #-}+module Language.Haskell.Homplexity.RecordFieldsCount(+    RecordFieldsCount+  , recordFieldsCountT+  ) where++--import Data.Maybe+import           Data.Proxy+import           Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Homplexity.CodeFragment+import           Language.Haskell.Homplexity.Metric+import           Language.Haskell.Homplexity.Utilities++newtype RecordFieldsCount = RecordFieldsCount { unFieldCount :: Int }+  deriving (Eq, Ord, Enum, Num, Real, Integral)++recordFieldsCountT :: Proxy RecordFieldsCount+recordFieldsCountT  = Proxy++instance Metric RecordFieldsCount DataDef where+  measure DataDef { .. } = RecordFieldsCount $ either measureCons measureGadts dataDefCtors++measureCons :: [QualConDecl SrcLoc] -> Int+measureCons = sumOf (\(QualConDecl _ _ _ decl) -> count decl)+  where+    count (ConDecl _ _ lst) = length lst+    count (RecDecl _ _ lst) = length lst+    count InfixConDecl {}   = 2++measureGadts :: [GadtDecl SrcLoc] -> Int+measureGadts = sumOf count+  where+#if MIN_VERSION_haskell_src_exts(1,21,0)+    count (GadtDecl _ _ _ _ maybeFields _) = maybe 0 length maybeFields+#else+    count (GadtDecl _ _     maybeFields _) = maybe 0 length maybeFields+#endif++instance Show RecordFieldsCount where+  showsPrec _ (RecordFieldsCount rfc) = ("record fields count of " ++)+                                      . shows rfc

@@ -0,0 +1,65 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+-- | Measuring the complexity of type class declarations+module Language.Haskell.Homplexity.TypeClassComplexity+  ( NonTypeDeclCount+  , nonTypeDeclCountT+  , AssocTypeCount+  , assocTypeCountT+  ) where++import           Data.Data+import           Data.Generics.Uniplate.Data              ()+import           Data.Maybe+--import Language.Haskell.Exts.SrcLoc+import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Homplexity.CodeFragment+import           Language.Haskell.Homplexity.Metric+import           Language.Haskell.Homplexity.Utilities++-- NOTE: It is non-trivial to decide whether a class declaration+-- is a method or a value. To correctly do that, we would have to+-- see through type synonyms. So, we will aggregate methods and values.++-- * Type class method count+-- | Represents the number of methods and value in a type class.+newtype NonTypeDeclCount = NonTypeDeclCount { unNonTypeDeclCount :: Int }+  deriving (Eq, Ord, Enum, Num, Real, Integral)++-- | For passing @NonTypeDeclCount@ type as parameter.+nonTypeDeclCountT :: Proxy NonTypeDeclCount+nonTypeDeclCountT  = Proxy++instance Show NonTypeDeclCount where+  showsPrec _ (NonTypeDeclCount mc) = ("method + value count of " ++)+                                    . shows mc++instance Metric NonTypeDeclCount TypeClass where+  measure = NonTypeDeclCount . sumOf method . fromMaybe [] . tcDecls where++    method :: ClassDecl l -> Int+    method (ClsDecl _ TypeSig{}) = 1+    method _                     = 0++-- * Type class associated types count+-- | Represents the number of associated types in a type class.+-- It includes both associated type and data families.+newtype AssocTypeCount = AssocTypeCount { unAssocTypeCount :: Int }+  deriving (Eq, Ord, Enum, Num, Real, Integral)++-- | For passing @AssocTypeCount@ type as parameter.+assocTypeCountT :: Proxy AssocTypeCount+assocTypeCountT  = Proxy++instance Show AssocTypeCount where+  showsPrec _ (AssocTypeCount atc) = ("associated type count of " ++)+                                   . shows atc++instance Metric AssocTypeCount TypeClass where+  measure = AssocTypeCount . sumOf assocType . fromMaybe [] . tcDecls where++    assocType :: ClassDecl l -> Int+    assocType ClsTyFam{}   = 1+    assocType ClsTyDef{}   = 1+    assocType ClsDataFam{} = 1+    assocType _            = 0

@@ -0,0 +1,22 @@+module Language.Haskell.Homplexity.Utilities(+    sumOf+  , maxOf+  , declHeadName+  ) where++import Language.Haskell.Exts.Syntax (DeclHead(..), Name)++-- | Maximum of the results of mapping the function over the list.+maxOf :: (a -> Int) -> [a] -> Int+maxOf f = maximum . (0:). map f++-- | Sum the results of mapping the function over the list.+sumOf :: (a -> Int) -> [a] -> Int+sumOf f = sum . map f++-- | Get the name of a declaration.+declHeadName :: DeclHead l -> Name l+declHeadName (DHead _ name)     = name+declHeadName (DHInfix _ _ name) = name+declHeadName (DHParen _ dh)     = declHeadName dh+declHeadName (DHApp _ dh _)     = declHeadName dh

@@ -1,60 +0,0 @@-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE QuasiQuotes           #-}-module Main (-    main -  ) where--import Data.Char-import Data.List-import Control.Exception as E--import Language.Haskell.Exts.SrcLoc-import Language.Haskell.Exts--import Language.Haskell.Homplexity.Comments-import Language.Haskell.Homplexity.Parse-import Language.Haskell.Homplexity.Metric--import TestSource---- * Tests for comment types-prop_commentsAfter ::  Bool-prop_commentsAfter  = findCommentType "  |" == CommentsAfter--prop_commentsBefore ::  Bool-prop_commentsBefore = findCommentType "  ^" == CommentsBefore--prop_commentsGroup ::  Bool-prop_commentsGroup  = findCommentType "  *" == CommentsInside--prop_commentsInside ::  Bool-prop_commentsInside = findCommentType "  a" == CommentsInside--testSrc = do-  (ast, comments) <- [tsrc|-module Amanitas where--- | This is comment preceeding variable "a"-a=1-b=2--- ^ This is comment following variable "b"-|]-  putStrLn $ "Comments:\n" ++ show comments-  assert (and [length comments == 2-              ]) $-    return ()---src = $withLocation "mystring"---- Runs all unit tests.-main :: IO ()-main  = do-  assert (and [prop_commentsAfter-              ,prop_commentsBefore-              ,prop_commentsGroup-              ,prop_commentsInside]) $-    return ()-  testSrc

@@ -0,0 +1,22 @@+{-# LANGUAGE TypeApplications #-}+module Test.Metrics.TypeClassComplexitySpec where+++import Test.Hspec+import Test.Utilities++import Language.Haskell.Exts.Extension+import Language.Haskell.Homplexity.TypeClassComplexity+import Language.Haskell.Homplexity.CodeFragment (TypeClass)++spec :: Spec+spec = describe "tests for type class complexity" $ do+  it "correctly counts methods and values" $ flip shouldReturn (5 :: NonTypeDeclCount) $ do+    measureSumOnFile @NonTypeDeclCount @TypeClass+      [] (testFile "TypeClassComplexityTest.hs")++  it "correctly counts associated types" $ flip shouldReturn (5 :: AssocTypeCount) $ do+    measureSumOnFile @AssocTypeCount @TypeClass+      [EnableExtension TypeFamilies] (testFile "TypeClassComplexityTest.hs")++

@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE QuasiQuotes           #-}+module Test.Parse.CommentsSpec where+++import Test.Hspec++import Language.Haskell.Homplexity.Comments++import Test.Utils+++spec :: Spec+spec = describe "tests for comments" $ do+    it "must parse comments after" $ example $+        findCommentType "  |" `shouldBe` CommentsAfter+    it "must parse comments before" $ example $+        findCommentType "  ^" `shouldBe` CommentsBefore+    it "must parse comments group" $ example $+        findCommentType "  *" `shouldBe` CommentsInside+    it "must parse comments inside" $ example $+        findCommentType "  a" `shouldBe` CommentsInside+    it "must output comments" $ example $ do+        (_ast, comments) <- [tsrc|+            module Amanitas where+            -- | This is comment preceeding variable "a"+            a=1+            b=2+            -- ^ This is comment following variable "b"+            |]+        (length comments) `shouldBe` 2

@@ -0,0 +1,64 @@+module Test.Parse.ExtensionsSpec where+++import System.FilePath+import Language.Haskell.Exts.Extension++import Test.Hspec+import Test.Utilities++import Language.Haskell.Homplexity.Parse+import Language.Haskell.Homplexity.CabalFiles+++spec :: Spec+spec = describe "extensions support" $ do+    it "must parse language pragma in file" $+        parseSource [] (testFile "test0001.hs") >>= (`shouldSatisfy` isRight)+    it "can parse language pragmas in file" $+        parseSource [] (testFile "test0001.hs") >>= (`shouldSatisfy` isRight)+    it "can't parse without language pragmas in file" $+        parseSource [] (testFile "test0002.hs") >>= (`shouldSatisfy` isLeft)+    it "can parse with additional pragmas" $+        parseSource [EnableExtension ScopedTypeVariables] (testFile "test0002.hs") >>= (`shouldSatisfy` isRight)+    it "pragmas in file must override additional pragmas" $+        parseSource [DisableExtension ScopedTypeVariables] (testFile "test0001.hs") >>= (`shouldSatisfy` isRight)+    it "disabling must works as disabling" $+        parseSource [DisableExtension ScopedTypeVariables] (testFile "test0002.hs") >>= (`shouldSatisfy` isLeft)+    -- * Testing for cabal file processing+    it "must extract language extensions from library from cabal" $+        parseCabalFile (testFile "test0003.cabal")+        >>= return . languageExtensions Library . fromRight (error "Can't parse test cabal file")+        >>= (`shouldBe` [EnableExtension FlexibleContexts,+                         EnableExtension FlexibleInstances,+                         EnableExtension UndecidableInstances,+                         EnableExtension OverlappingInstances])+    it "extract language extensions from package from cabal" $+        parseCabalFile (testFile "test0003.cabal")+        >>= return . languageExtensions (Package "test01") . fromRight (error "Can't parse test cabal file")+        >>= (`shouldBe` [EnableExtension DeriveDataTypeable,+                         EnableExtension RecordWildCards])+++-- * Code from Data.Either --+-- Not supported by earlier 'base' package++isRight :: Either a b -> Bool+isRight (Right _) = True+isRight _ = False+++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False+++fromRight :: b -> Either a b -> b+fromRight _ (Right b) = b+fromRight def _ = def+++-- fromLeft :: a -> Either a b -> a+-- fromLeft _ (Left a) = a+-- fromLeft def _ = def+

@@ -0,0 +1,25 @@+{-# LANGUAGE AllowAmbiguousTypes, ScopedTypeVariables #-}+module Test.Utilities+  ( testFile+  , measureSumOnFile+  ) where++import System.FilePath (FilePath, (</>))++import Language.Haskell.Exts (Extension)+import Language.Haskell.Homplexity.CodeFragment (occurs)+import Language.Haskell.Homplexity.Metric (Metric(..))+import Language.Haskell.Homplexity.Parse (parseSource)++-- | Constructs OS-independent path to test file+testFile :: FilePath -> FilePath+testFile fn = "tests" </> "test-data" </> fn++measureSumOnFile :: forall m c. (Metric m c, Num m) => [Extension] -> FilePath -> IO m+measureSumOnFile exts path = do+  result <- parseSource exts path+  p <- case result of+    Left  logs      -> error $ show logs+    Right (prog, _) -> pure prog+  let codeFrags = occurs p :: [c]+  pure $ sum $ map measure codeFrags

@@ -0,0 +1,38 @@+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+-- | This module allows embedding source modules+-- Example:+-- +-- example1 :: IO ParseResult+-- example1 = [tsrc|+-- mod ule Main where+-- a=1+-- |]+-- -- Filename and line where error happens will be correctly reported by Haskell parser.++module Test.Utils(tsrc) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Language.Haskell.Homplexity.Parse(parseTest)++-- | QuasiQuoter for a non-interpolating String+tsrc :: QuasiQuoter+tsrc  = QuasiQuoter  embedSource+                    (error "Cannot use tsrc as a pattern")+                    (error "Cannot use tsrc as a type"   )+                    (error "Cannot use tsrc as a dec"    )+embedSource :: String -> Q Exp+embedSource aString = do+  loc <- location+  let theString = linePragma loc ++ aString      -- ^ Passes the information about correct location to the source+  let testNote  = "Test line "   ++ showLine loc -- ^ Shown in case that LINE pragma is not parsed+  [|parseTest testNote|] `appE` [| theString |]+-- parseTest :: FilePath -> String -> IO ParseResult++linePragma    :: Loc -> String+linePragma loc = concat ["{-# LINE ", showLine loc, " \"", loc_filename loc, "\" #-}\n"]++showLine :: Loc -> String+showLine = show . fst . loc_start

@@ -1,38 +0,0 @@-{-# LANGUAGE QuasiQuotes     #-}-{-# LANGUAGE TemplateHaskell #-}--- | This module allows embedding source modules--- Example:--- --- example1 :: IO ParseResult--- example1 = [tsrc|--- mod ule Main where--- a=1--- |]--- -- Filename and line where error happens will be correctly reported by Haskell parser.--module TestSource(tsrc) where--import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Language.Haskell.Homplexity.Parse(parseTest)---- | QuasiQuoter for a non-interpolating String-tsrc :: QuasiQuoter-tsrc  = QuasiQuoter  embedSource-                    (error "Cannot use tsrc as a pattern")-                    (error "Cannot use tsrc as a type"   )-                    (error "Cannot use tsrc as a dec"    )-embedSource :: String -> Q Exp-embedSource aString = do-  loc <- location-  let theString = linePragma loc ++ aString      -- ^ Passes the information about correct location to the source-  let testNote  = "Test line "   ++ showLine loc -- ^ Shown in case that LINE pragma is not parsed-  [|parseTest testNote|] `appE` [| theString |]--- parseTest :: FilePath -> String -> IO ParseResult--linePragma    :: Loc -> String-linePragma loc = concat ["{-# LINE ", showLine loc, " \"", loc_filename loc, "\" #-}\n"]--showLine :: Loc -> String-showLine = show . fst . loc_start

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}