diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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? ----------------- diff --git a/app/Homplexity.hs b/app/Homplexity.hs --- a/app/Homplexity.hs +++ b/app/Homplexity.hs @@ -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) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/homplexity.cabal b/homplexity.cabal --- a/homplexity.cabal +++ b/homplexity.cabal @@ -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" diff --git a/lib/Language/Haskell/Homplexity/Assessment.hs b/lib/Language/Haskell/Homplexity/Assessment.hs --- a/lib/Language/Haskell/Homplexity/Assessment.hs +++ b/lib/Language/Haskell/Homplexity/Assessment.hs @@ -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 + ] diff --git a/lib/Language/Haskell/Homplexity/CabalFiles.hs b/lib/Language/Haskell/Homplexity/CabalFiles.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Homplexity/CabalFiles.hs @@ -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) ] + diff --git a/lib/Language/Haskell/Homplexity/CodeFragment.hs b/lib/Language/Haskell/Homplexity/CodeFragment.hs --- a/lib/Language/Haskell/Homplexity/CodeFragment.hs +++ b/lib/Language/Haskell/Homplexity/CodeFragment.hs @@ -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 _ _ _) = "" 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 diff --git a/lib/Language/Haskell/Homplexity/Comments.hs b/lib/Language/Haskell/Homplexity/Comments.hs --- a/lib/Language/Haskell/Homplexity/Comments.hs +++ b/lib/Language/Haskell/Homplexity/Comments.hs @@ -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) diff --git a/lib/Language/Haskell/Homplexity/Cyclomatic.hs b/lib/Language/Haskell/Homplexity/Cyclomatic.hs --- a/lib/Language/Haskell/Homplexity/Cyclomatic.hs +++ b/lib/Language/Haskell/Homplexity/Cyclomatic.hs @@ -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) diff --git a/lib/Language/Haskell/Homplexity/Message.hs b/lib/Language/Haskell/Homplexity/Message.hs --- a/lib/Language/Haskell/Homplexity/Message.hs +++ b/lib/Language/Haskell/Homplexity/Message.hs @@ -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 - diff --git a/lib/Language/Haskell/Homplexity/Metric.hs b/lib/Language/Haskell/Homplexity/Metric.hs --- a/lib/Language/Haskell/Homplexity/Metric.hs +++ b/lib/Language/Haskell/Homplexity/Metric.hs @@ -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. diff --git a/lib/Language/Haskell/Homplexity/Parse.hs b/lib/Language/Haskell/Homplexity/Parse.hs --- a/lib/Language/Haskell/Homplexity/Parse.hs +++ b/lib/Language/Haskell/Homplexity/Parse.hs @@ -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 diff --git a/lib/Language/Haskell/Homplexity/RecordFieldsCount.hs b/lib/Language/Haskell/Homplexity/RecordFieldsCount.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Homplexity/RecordFieldsCount.hs @@ -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 diff --git a/lib/Language/Haskell/Homplexity/TypeClassComplexity.hs b/lib/Language/Haskell/Homplexity/TypeClassComplexity.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Homplexity/TypeClassComplexity.hs @@ -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 diff --git a/lib/Language/Haskell/Homplexity/Utilities.hs b/lib/Language/Haskell/Homplexity/Utilities.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Haskell/Homplexity/Utilities.hs @@ -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 diff --git a/tests/Comments.hs b/tests/Comments.hs deleted file mode 100644 --- a/tests/Comments.hs +++ /dev/null @@ -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 diff --git a/tests/Test/Metrics/TypeClassComplexitySpec.hs b/tests/Test/Metrics/TypeClassComplexitySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Metrics/TypeClassComplexitySpec.hs @@ -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") + + diff --git a/tests/Test/Parse/CommentsSpec.hs b/tests/Test/Parse/CommentsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Parse/CommentsSpec.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 diff --git a/tests/Test/Parse/ExtensionsSpec.hs b/tests/Test/Parse/ExtensionsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Parse/ExtensionsSpec.hs @@ -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 + diff --git a/tests/Test/Utilities.hs b/tests/Test/Utilities.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Utilities.hs @@ -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 diff --git a/tests/Test/Utils.hs b/tests/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Utils.hs @@ -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 diff --git a/tests/TestSource.hs b/tests/TestSource.hs deleted file mode 100644 --- a/tests/TestSource.hs +++ /dev/null @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}