├── .envrc ├── .gitignore ├── .hlint.yaml ├── LICENSE.md ├── README.md ├── cabal.project ├── dekking-plugin ├── .gitignore ├── default.nix ├── dekking-plugin.cabal ├── package.yaml └── src │ └── Dekking │ ├── Coverable.hs │ ├── Plugin.hs │ └── SourceAdapter.hs ├── dekking-report ├── .gitignore ├── app │ └── Main.hs ├── default.nix ├── dekking-report.cabal ├── package.yaml ├── src │ └── Dekking │ │ ├── Coverage.hs │ │ ├── OptParse.hs │ │ └── Report.hs └── templates │ ├── index.hamlet │ ├── module.hamlet │ ├── package.hamlet │ ├── progress-bar.hamlet │ ├── script.julius │ └── style.lucius ├── dekking-value ├── .gitignore ├── default.nix ├── dekking-value.cabal ├── package.yaml └── src │ └── Dekking │ └── ValueLevelAdapter.hs ├── docs ├── strategy.dot └── strategy.svg ├── e2e-test ├── default.nix ├── example │ ├── .gitignore │ ├── default.nix │ ├── example.cabal │ ├── package.yaml │ ├── src │ │ └── Lib.hs │ └── test │ │ └── Spec.hs ├── foobar-gen │ ├── .gitignore │ ├── default.nix │ ├── foobar-gen.cabal │ ├── package.yaml │ ├── src │ │ └── Foobar │ │ │ └── Gen.hs │ └── test │ │ └── Spec.hs ├── foobar │ ├── .gitignore │ ├── default.nix │ ├── foobar.cabal │ ├── package.yaml │ └── src │ │ └── Foobar.hs └── syntax │ ├── .gitignore │ ├── default.nix │ ├── package.yaml │ ├── src │ ├── Annotations.hs │ ├── Lens.hs │ ├── OverloadedStrings.hs │ ├── Paren.hs │ ├── Record.hs │ ├── ServantExample.hs │ ├── TopLevel.hs │ ├── TypeApplications.hs │ └── Typeclass.hs │ ├── syntax.cabal │ └── test │ └── Spec.hs ├── flake.lock ├── flake.nix └── nix ├── addCoverables.nix ├── addCoverage.nix ├── addCoverageReport.nix ├── addDekkingValueDependency.nix ├── compileCoverageReport.nix ├── makeCoverageReport.nix ├── overlay.nix └── overrides.nix /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.coverables 2 | coverage.dat 3 | *.html 4 | *.css 5 | *.json 6 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: 2 | name: "Use newtype instead of data" 3 | - ignore: 4 | name: "Use ++" 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # Dekking License 2 | 3 | Copyright (c) 2022-2023 Tom Sydney Kerckhove 4 | 5 | ## Anyone 6 | 7 | **Anyone** can use this software to test your software under the following license: 8 | 9 | 10 | ### Permissions: 11 | 12 | * The licensed software may be distributed. 13 | * The licensed software may be modified. 14 | * The licensed software may be used to test the software under test. 15 | 16 | ### Conditions: 17 | 18 | * _The software under test is not used for commercial purposes._ 19 | **OR** 20 | _The software under test is open-source software licensed according to an [OSI-approved Open Source license](https://opensource.org/licenses)._ 21 | * Any modifications to the licensed software must be made public under the same license with the same copyright holder. 22 | * The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 23 | 24 | ### Limitations: 25 | 26 | * The software is provided "as is", without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. 27 | * In no event shall the authors or copyright holders be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the software or the use or other dealings in the software. 28 | 29 | 30 | ## Contributors and Sponsors 31 | 32 | **Contributors listed in [CONTRIBUTORS](./CONTRIBUTORS) or [GitHub sponsors of NorfairKing](https://github.com/sponsors/NorfairKing)** can use this software to test their software under the following conditions: 33 | 34 | ### Permissions 35 | 36 | Any 37 | 38 | ### Conditions 39 | 40 | * The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 41 | 42 | ### Limitations 43 | 44 | * The software is provided "as is", without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. 45 | * In no event shall the authors or copyright holders be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the software or the use or other dealings in the software. 46 | 47 | ## Other arrangements 48 | 49 | **You can [contact me](https://cs-syd.eu/contact) for other arrangements (like a permanent license) on a case-to-case basis.** 50 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Next-gen test coverage reports for Haskell 2 | 3 | Dekking is a next-generation coverage report tool for Haskell. 4 | It is implemented as a GHC plugin, as opposed to [HPC](https://hackage.haskell.org/package/hpc), which is built into GHC. 5 | 6 | Current status: Used in Prod in all my products. 7 | 8 | ## Strategy 9 | 10 | There are a few pieces of the puzzle. 11 | The relevant programs are: 12 | 13 | * `dekking-plugin`: 14 | Modifies the parsed source file within GHC as a source-to-source 15 | transformation plugin. 16 | At compile-time, this plugin also outputs a `.hs.coverables` file which 17 | contains information about which parts of the source file are coverable and 18 | where those pieces are within the source. 19 | The source is transformed such that, when compiled, the result will output 20 | coverage information in `coverage.dat`. 21 | * `ghc`: Compiles the resulting modified source code 22 | * `dekking-report`: 23 | Takes the `*.hs.coverables` files, and any number of `coverage.dat` files, 24 | and produces a machine-readable `report.json` file, as well as human 25 | readable HTML files which can be viewed in a browser. 26 | 27 | ### Source-to-source transformation 28 | 29 | The source-to-source transformation works as follows; 30 | 31 | We replace every expression `e` by `adaptValue "identifier for e" e`. 32 | The identifier is generated by `dekking-plugin` at parse-time. 33 | 34 | To give an idea of what this looks like, we would transform this 35 | expression: 36 | 37 | ``` 38 | ((a + b) * c) 39 | ``` 40 | 41 | into this expression (`f = adaptValue "identifier for e"`): 42 | 43 | ``` 44 | ((f a) + (f b)) * (f c) 45 | ``` 46 | 47 | ### The value adapter 48 | 49 | The `adaptValue` function mentioned above is implemented in the very small `dekking-value` package, in the `Dekking.ValueLevelAdapter` module. 50 | 51 | It looks something like this: 52 | 53 | ``` haskell 54 | {-# NOINLINE adaptValue #-} 55 | adaptValue :: String -> (forall a. a -> a) 56 | adaptValue logStr = unsafePerformIO $ do 57 | hPutStrLn coverageHandle logStr 58 | hFlush coverageHandle 59 | pure id 60 | ``` 61 | 62 | This function uses the _problem_ of `unsafePerformIO`, namely that the IO is only executed once, as a way to make sure that each expression is only marked as covered once. 63 | 64 | ### Coverables 65 | 66 | Each coverable comes with a location, which is a triple of a line number, a 67 | starting column and an ending column. 68 | This location specifies where the coverable can be found in the source code. 69 | 70 | The `*.hs.coverables` files are machine-readable JSON files. 71 | 72 | ### Coverage 73 | 74 | The `coverage.dat` files are text files with a line-by-line description of which pieces of the source have been covered. 75 | Each line is split up into five pieces: 76 | 77 | ``` 78 | 79 | ``` 80 | For example: 81 | ``` 82 | dekking-test-0.0.0.0 Examples.Multi.A 4 1 5 83 | ``` 84 | 85 | ### Strategy Overview 86 | 87 | ![Strategy graph](docs/strategy.svg) 88 | 89 | ### Nix API 90 | 91 | Nix support is a strong requirement of the `dekking` project. 92 | A flake has been provided. 93 | The default package contains the following `passthru` attributes: 94 | 95 | * `addCoverables`: Add a `coverables` output to a Haskell package. 96 | * `addCoverage`: Add a `coverage` output to a Haskell package. 97 | * `addCoverablesAndCoverage`: both of the above 98 | * `addCoverageReport`: Add a coverage `report` output to a Haskell package, similar to `doCoverage`. 99 | * `compileCoverageReport`: Compile a coverage report (internal, you probably won't need this.) 100 | * `makeCoverageReport`: Produce a coverage report from multiple Haskell packages. 101 | Example usage: 102 | ``` nix 103 | { 104 | fuzzy-time-report = dekking.makeCoverageReport { 105 | name = "fuzzy-time-coverage-report"; 106 | packages = [ 107 | "fuzzy-time" 108 | "fuzzy-time-gen" 109 | ]; 110 | }; 111 | } 112 | ``` 113 | 114 | See the `e2e-test` directory for many more examples. 115 | 116 | ### Why a source-to-source transformation? 117 | 118 | TODO 119 | 120 | ### Why is there no separate coverage for top-level bindings, patterns, or alternatives? 121 | 122 | Only expressions are evaluated, so only expressions can be covered. 123 | Expression coverage also shows you alternative coverage because alternatives 124 | point to an expression. 125 | Top-level bindings are not somehow special either. 126 | They are a code organisation tool that need not have any impact on whether 127 | covering them is more important. 128 | 129 | ## Why are there no controls to fail when a coverage percentage is not met? 130 | 131 | Making automated decisions using a coverage percentage is usually a 132 | shortsighted way to use that number. 133 | If you really want to automate such a thing, you can use the `report.json` file 134 | that `dekking-report` outputs. 135 | 136 | ## Some part of my code fails to compile with coverage 137 | 138 | Because of `RankNTypes` and limitations of `ImpredicativeTypes`, sometimes the source-transformed version of a function does not type-check anymore. 139 | (See `[ref:ThePlanTM]`, `[ref:-XImpredicativeTypes]`, and `[ref:DisablingCoverage]`.) 140 | A common example is Servant's `hoistServerWithContext`, see [ghc ticket 22543](https://gitlab.haskell.org/ghc/ghc/-/issues/22543). 141 | 142 | There are three ways to selectively turn off coverage: 143 | 144 | 1. With an `--exception` for the plugin: `-fplugin-opt=Dekking.Plugin:--exception=My.Module` 145 | 2. With a module-level annotation: `{-# ANN module "NOCOVER" #-}` 146 | 3. With a function-level annotation: `{-# ANN hoistServerWithContext "NOCOVER" #-}` 147 | 148 | 149 | ## Why not "just" use HPC? 150 | 151 | * Strong nix support 152 | * Multi-package coverage reports 153 | * Coupling with GHC 154 | 155 | TODO write these out 156 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | */*.cabal 3 | e2e-test/*/*.cabal 4 | test-show-details: direct 5 | -------------------------------------------------------------------------------- /dekking-plugin/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /dekking-plugin/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, aeson-pretty, autodocodec, base, bytestring 2 | , containers, ghc, ghc-boot, lib, mtl, path, path-io, text 3 | }: 4 | mkDerivation { 5 | pname = "dekking-plugin"; 6 | version = "0.0.0.0"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | aeson aeson-pretty autodocodec base bytestring containers ghc 10 | ghc-boot mtl path path-io text 11 | ]; 12 | homepage = "https://github.com/NorfairKing/dekking#readme"; 13 | license = "unknown"; 14 | } 15 | -------------------------------------------------------------------------------- /dekking-plugin/dekking-plugin.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: dekking-plugin 8 | version: 0.0.0.0 9 | homepage: https://github.com/NorfairKing/dekking#readme 10 | bug-reports: https://github.com/NorfairKing/dekking/issues 11 | author: Tom Sydney Kerckhove 12 | maintainer: Tom Sydney Kerckhove 13 | build-type: Simple 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/NorfairKing/dekking 18 | 19 | library 20 | exposed-modules: 21 | Dekking.Coverable 22 | Dekking.Plugin 23 | Dekking.SourceAdapter 24 | other-modules: 25 | Paths_dekking_plugin 26 | hs-source-dirs: 27 | src 28 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages 29 | build-depends: 30 | aeson 31 | , aeson-pretty 32 | , autodocodec 33 | , base >=4.7 && <5 34 | , bytestring 35 | , containers 36 | , ghc 37 | , ghc-boot 38 | , mtl 39 | , path 40 | , path-io 41 | , text 42 | default-language: Haskell2010 43 | -------------------------------------------------------------------------------- /dekking-plugin/package.yaml: -------------------------------------------------------------------------------- 1 | name: dekking-plugin 2 | version: 0.0.0.0 3 | github: "NorfairKing/dekking" 4 | author: "Tom Sydney Kerckhove" 5 | 6 | dependencies: 7 | - base >= 4.7 && < 5 8 | 9 | ghc-options: 10 | - -Wall 11 | - -Widentities 12 | - -Wincomplete-record-updates 13 | - -Wincomplete-uni-patterns 14 | - -Wmissing-home-modules 15 | - -Wpartial-fields 16 | - -Wredundant-constraints 17 | - -Wunused-packages 18 | 19 | library: 20 | source-dirs: src 21 | dependencies: 22 | - aeson 23 | - aeson-pretty 24 | - autodocodec 25 | - bytestring 26 | - containers 27 | - ghc 28 | - ghc-boot 29 | - mtl 30 | - path 31 | - path-io 32 | - text 33 | -------------------------------------------------------------------------------- /dekking-plugin/src/Dekking/Coverable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Dekking.Coverable where 6 | 7 | import Autodocodec 8 | import Control.Monad 9 | import Data.Aeson (FromJSON, ToJSON, eitherDecodeFileStrict) 10 | import Data.Aeson.Encode.Pretty (encodePretty) 11 | import qualified Data.ByteString as SB 12 | import qualified Data.ByteString.Lazy as LB 13 | import Data.List 14 | import Data.Map (Map) 15 | import qualified Data.Map as M 16 | import Data.Set (Set) 17 | import qualified Data.Set as S 18 | import Path 19 | import Path.IO 20 | 21 | newtype Coverables = Coverables 22 | { coverablesModules :: Map PackageName (Map ModuleName (String, ModuleCoverables)) 23 | } 24 | deriving stock (Show, Eq) 25 | deriving (FromJSON, ToJSON) via (Autodocodec Coverables) 26 | 27 | instance Semigroup Coverables where 28 | (<>) c1 c2 = 29 | Coverables 30 | { coverablesModules = 31 | coverablesModules c1 Prelude.<> coverablesModules c2 32 | } 33 | 34 | instance Monoid Coverables where 35 | mempty = Coverables {coverablesModules = mempty} 36 | mappend = (Prelude.<>) 37 | 38 | instance HasCodec Coverables where 39 | codec = 40 | dimapCodec Coverables coverablesModules $ 41 | mapCodec $ 42 | mapCodec $ 43 | object "CoverablesWithSource" $ 44 | (,) 45 | <$> requiredField "source" "source code" .= fst 46 | <*> requiredField "coverables" "coverables" .= snd 47 | 48 | data ModuleCoverablesFile = ModuleCoverablesFile 49 | { moduleCoverablesFilePackageName :: PackageName, 50 | moduleCoverablesFileModuleName :: ModuleName, 51 | moduleCoverablesFileSource :: String, 52 | moduleCoverablesFileCoverables :: ModuleCoverables 53 | } 54 | deriving stock (Show, Eq) 55 | deriving (FromJSON, ToJSON) via (Autodocodec ModuleCoverablesFile) 56 | 57 | instance HasCodec ModuleCoverablesFile where 58 | codec = 59 | object "ModuleCoverablesFile" $ 60 | ModuleCoverablesFile 61 | <$> requiredField "package-name" "Package name" .= moduleCoverablesFilePackageName 62 | <*> requiredField "module-name" "Module name" .= moduleCoverablesFileModuleName 63 | <*> requiredField "source" "source code" .= moduleCoverablesFileSource 64 | <*> requiredField "coverables" "coverables" .= moduleCoverablesFileCoverables 65 | 66 | data ModuleCoverables = ModuleCoverables 67 | { moduleCoverablesExpressions :: Set (Coverable Expression) 68 | } 69 | deriving stock (Show, Eq) 70 | deriving (FromJSON, ToJSON) via (Autodocodec ModuleCoverables) 71 | 72 | instance Semigroup ModuleCoverables where 73 | (<>) mc1 mc2 = 74 | ModuleCoverables 75 | { moduleCoverablesExpressions = moduleCoverablesExpressions mc1 <> moduleCoverablesExpressions mc2 76 | } 77 | 78 | instance Monoid ModuleCoverables where 79 | mempty = 80 | ModuleCoverables 81 | { moduleCoverablesExpressions = mempty 82 | } 83 | mappend = (<>) 84 | 85 | instance HasCodec ModuleCoverables where 86 | codec = 87 | object "ModuleCoverables" $ 88 | ModuleCoverables 89 | <$> optionalFieldWithOmittedDefault "expressions" mempty "Expressions" .= moduleCoverablesExpressions 90 | 91 | data Coverable a = Coverable 92 | { coverableValue :: !a, 93 | coverableLocation :: !Location 94 | } 95 | deriving stock (Show, Eq, Ord) 96 | 97 | instance (HasCodec a) => HasCodec (Coverable a) where 98 | codec = 99 | object "Coverable" $ 100 | Coverable 101 | <$> requiredField "value" "the value to be covered" .= coverableValue 102 | <*> requiredField "location" "the location of the value to be covered" .= coverableLocation 103 | 104 | data Location = Location 105 | { locationLine :: Word, 106 | locationColumnStart :: Word, 107 | locationColumnEnd :: Word 108 | } 109 | deriving stock (Show, Eq, Ord) 110 | 111 | instance HasCodec Location where 112 | codec = 113 | object "Location" $ 114 | Location 115 | <$> requiredField "line" "the line number" .= locationLine 116 | <*> requiredField "start" "the start column" .= locationColumnStart 117 | <*> requiredField "end" "the end column" .= locationColumnEnd 118 | 119 | locationString :: Location -> String 120 | locationString Location {..} = unwords [show locationLine, show locationColumnStart, show locationColumnEnd] 121 | 122 | newtype Expression = Expression {expressionIdentifier :: Maybe String} 123 | deriving stock (Show, Eq, Ord) 124 | 125 | instance HasCodec Expression where 126 | codec = dimapCodec Expression expressionIdentifier codec 127 | 128 | type PackageName = String 129 | 130 | type ModuleName = String 131 | 132 | readModuleCoverablesFile :: Path Abs File -> IO ModuleCoverablesFile 133 | readModuleCoverablesFile p = do 134 | errOrRes <- eitherDecodeFileStrict (fromAbsFile p) 135 | case errOrRes of 136 | Left err -> 137 | fail $ 138 | unlines 139 | [ unwords 140 | [ "Failed to parse coverables file:", 141 | fromAbsFile p 142 | ], 143 | err 144 | ] 145 | Right result -> pure result 146 | 147 | writeModuleCoverablesFile :: Path Abs File -> ModuleCoverablesFile -> IO () 148 | writeModuleCoverablesFile p moduleCoverables = do 149 | SB.writeFile (fromAbsFile p) (LB.toStrict (encodePretty moduleCoverables)) 150 | 151 | readCoverablesFiles :: Set (Path Abs Dir) -> IO Coverables 152 | readCoverablesFiles dirs = do 153 | coverablesFiles <- 154 | filter 155 | (maybe False (isSuffixOf coverablesExtension) . fileExtension) 156 | . concat 157 | <$> mapM (fmap snd . listDirRecur) (S.toList dirs) 158 | fmap (Coverables . M.unionsWith M.union) $ 159 | forM coverablesFiles $ \coverablesFilePath -> do 160 | coverablesFile <- readModuleCoverablesFile coverablesFilePath 161 | pure $ 162 | M.singleton 163 | (moduleCoverablesFilePackageName coverablesFile) 164 | ( M.singleton 165 | (moduleCoverablesFileModuleName coverablesFile) 166 | (moduleCoverablesFileSource coverablesFile, moduleCoverablesFileCoverables coverablesFile) 167 | ) 168 | 169 | coverablesExtension :: String 170 | coverablesExtension = ".coverables" 171 | -------------------------------------------------------------------------------- /dekking-plugin/src/Dekking/Plugin.hs: -------------------------------------------------------------------------------- 1 | module Dekking.Plugin (plugin) where 2 | 3 | import Control.Monad 4 | import Control.Monad.Reader 5 | import Control.Monad.Writer.Strict 6 | import Data.List (isPrefixOf, stripPrefix) 7 | import Data.Maybe (mapMaybe) 8 | import Dekking.Coverable 9 | import Dekking.SourceAdapter 10 | import GHC 11 | import qualified GHC.Data.EnumSet as EnumSet 12 | import GHC.Driver.Env 13 | import GHC.Driver.Plugins 14 | import GHC.Driver.Session 15 | import GHC.LanguageExtensions 16 | import Path 17 | import Path.IO 18 | 19 | plugin :: Plugin 20 | plugin = 21 | defaultPlugin 22 | { driverPlugin = \_ -> pure . hscUpdateFlags fixDynFlags, 23 | parsedResultAction = adaptParseResult 24 | } 25 | 26 | fixDynFlags :: DynFlags -> DynFlags 27 | fixDynFlags = 28 | -- See [ref:-XImpredicativeTypes] 29 | let setImpredicativeTypes fs = xopt_set fs ImpredicativeTypes 30 | -- Turn off safe haskell, because we don't care about it for a coverage report. 31 | turnOffSafeHaskell fs = fs {safeHaskell = Sf_Ignore} 32 | -- Turn off inferring safe haskell, because we don't care about it for a coverage report. 33 | turnOffSafeInfer fs = fs {safeInfer = False} 34 | -- Turn off all warnings, because the resulting source may cause warnings. 35 | -- This doesn't seem to work anymore as of ghc 9.4 so we do this is nix/addCoverables.nix instead. 36 | -- See [tag:TurningOffWarnings] 37 | turnOffWarnings fs = 38 | fs 39 | { warningFlags = EnumSet.empty, 40 | fatalWarningFlags = EnumSet.empty, 41 | generalFlags = EnumSet.delete Opt_WarnIsError $ generalFlags fs 42 | } 43 | in turnOffWarnings 44 | . turnOffSafeInfer 45 | . turnOffSafeHaskell 46 | . setImpredicativeTypes 47 | 48 | -- [tag:-XImpredicativeTypes] 49 | -- 50 | -- In order to perform the source-to-source transformation, we have to set 'ImpredicativeTypes'. 51 | -- 52 | -- For the purposes of this explanation, our sourc-transformation might 53 | -- as well be `a` -> `id a`. 54 | -- One would think (or at least I certainly did), that this would turn 55 | -- any piece of code that type-checksinto something that also 56 | -- type-checks. 57 | -- However, without 'ImpredicativeTypes', it doesn't. 58 | -- 59 | -- Indeed, without 'ImpredicativeTypes', this type-checks: 60 | -- 61 | -- ``` 62 | -- exampleStringL :: Lens' Example String 63 | -- exampleStringL = lens exampleString (\e s -> e {exampleString = s}) 64 | -- ``` 65 | -- 66 | -- But this doesn't: 67 | -- 68 | -- ``` 69 | -- exampleStringL :: Lens' Example String 70 | -- exampleStringL = (id lens) exampleString (\e s -> e {exampleString = s}) 71 | -- ``` 72 | -- 73 | -- For a simpler example, consider the following piece of code: 74 | -- (Thank you @lnnf107 on twitter!) 75 | -- 76 | -- ``` 77 | -- f :: Int -> (forall a. a -> a) 78 | -- ``` 79 | -- 80 | -- Our transformation would turn `f` into `id f`, but then GHC would try 81 | -- to instantiate the type-parameter of `id` with the polytype `Int -> 82 | -- (forall a. a -> a)`, which is only possible with ImpredicativeTypes. 83 | 84 | adaptParseResult :: [CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult 85 | adaptParseResult es ms pr = do 86 | let pm = parsedResultModule pr 87 | let m = ms_mod ms 88 | let mn = moduleName m 89 | let exceptionModules = mapMaybe (stripPrefix "--exception=") es 90 | if "Paths_" `isPrefixOf` moduleNameString mn || moduleNameString mn `elem` exceptionModules 91 | then pure pr 92 | else do 93 | -- Transform the source 94 | (lm', coverables) <- runReaderT (runWriterT (adaptLocatedHsModule (hpm_module pm))) m 95 | forM_ (ml_hs_file (ms_location ms)) $ \sourceFile -> 96 | -- Output the coverables 97 | liftIO $ do 98 | p <- resolveFile' sourceFile 99 | sourceCode <- readFile sourceFile 100 | coverablesFile <- addExtension coverablesExtension p 101 | putStrLn $ 102 | unwords 103 | [ "Outputing coverables file", 104 | fromAbsFile coverablesFile, 105 | "for source file", 106 | fromAbsFile p 107 | ] 108 | writeModuleCoverablesFile coverablesFile $ 109 | ModuleCoverablesFile 110 | { moduleCoverablesFilePackageName = unitToString (moduleUnit m), 111 | moduleCoverablesFileModuleName = moduleNameString mn, 112 | moduleCoverablesFileSource = sourceCode, 113 | moduleCoverablesFileCoverables = coverables 114 | } 115 | pure pr {parsedResultModule = pm {hpm_module = lm'}} 116 | -------------------------------------------------------------------------------- /dekking-plugin/src/Dekking/SourceAdapter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Dekking.SourceAdapter (adaptLocatedHsModule, unitToString) where 6 | 7 | import Control.Monad 8 | import Control.Monad.Reader 9 | import Control.Monad.Writer.Strict 10 | import Data.List 11 | import Data.Maybe 12 | import qualified Data.Set as S 13 | import qualified Data.Text as T 14 | import Dekking.Coverable 15 | import GHC hiding (moduleName) 16 | import GHC.Data.Bag 17 | import GHC.Plugins as GHC 18 | import GHC.Types.SourceText as GHC 19 | 20 | addExpression :: Coverable Expression -> AdaptM () 21 | addExpression e = tell (mempty {moduleCoverablesExpressions = S.singleton e}) 22 | 23 | type AdaptM = WriterT ModuleCoverables (ReaderT GHC.Module Hsc) 24 | 25 | adapterImport :: LImportDecl GhcPs 26 | adapterImport = noLocA (simpleImportDecl adapterModuleName) 27 | 28 | adapterModuleName :: GHC.ModuleName 29 | adapterModuleName = mkModuleName "Dekking.ValueLevelAdapter" 30 | 31 | adaptLocatedHsModule :: Located (HsModule GhcPs) -> AdaptM (Located (HsModule GhcPs)) 32 | adaptLocatedHsModule = traverse adaptHsModule 33 | 34 | adaptHsModule :: HsModule GhcPs -> AdaptM (HsModule GhcPs) 35 | adaptHsModule m = do 36 | let annotations = gatherAnnotations m 37 | if DontCoverModule `elem` annotations 38 | then pure m 39 | else do 40 | moduule <- ask 41 | liftIO $ putStrLn $ "Adapting module: " ++ moduleNameString (moduleName moduule) 42 | decls' <- mapM (adaptTopLevelLDecl annotations) (hsmodDecls m) 43 | pure 44 | ( m 45 | { hsmodDecls = decls', 46 | hsmodImports = 47 | -- See [ref:ThePlanTM] 48 | adapterImport : hsmodImports m 49 | } 50 | ) 51 | 52 | -- | Annotations that guide the plugin 53 | -- [tag:DisablingCoverage] 54 | data CoverAnnotation 55 | = DontCoverModule 56 | | DontCoverFunction String 57 | deriving (Show, Eq) 58 | 59 | gatherAnnotations :: HsModule GhcPs -> [CoverAnnotation] 60 | gatherAnnotations = mapMaybe (gatherAnnotationDecl . unLoc) . hsmodDecls 61 | 62 | gatherAnnotationDecl :: HsDecl GhcPs -> Maybe CoverAnnotation 63 | gatherAnnotationDecl = \case 64 | AnnD _ (HsAnnotation _ p body) -> do 65 | guard $ isNoCoverExpr body 66 | case p of 67 | ValueAnnProvenance rdr -> Just $ DontCoverFunction $ occNameString $ rdrNameOcc $ unLoc rdr 68 | ModuleAnnProvenance -> Just DontCoverModule 69 | _ -> Nothing 70 | _ -> Nothing 71 | 72 | isNoCoverExpr :: LHsExpr GhcPs -> Bool 73 | isNoCoverExpr expr = case unLoc expr of 74 | HsLit _ (HsString _ fs) | "NOCOVER" `isInfixOf` unpackFS fs -> True 75 | HsOverLit _ (OverLit _ (HsIsString _ fs)) | "NOCOVER" `isInfixOf` unpackFS fs -> True 76 | HsPar _ _ e _ -> isNoCoverExpr e 77 | ExprWithTySig _ e _ -> isNoCoverExpr e 78 | _ -> False 79 | 80 | adaptTopLevelLDecl :: [CoverAnnotation] -> LHsDecl GhcPs -> AdaptM (LHsDecl GhcPs) 81 | adaptTopLevelLDecl annotations = traverse $ adaptTopLevelDecl annotations 82 | 83 | adaptTopLevelDecl :: [CoverAnnotation] -> HsDecl GhcPs -> AdaptM (HsDecl GhcPs) 84 | adaptTopLevelDecl annotations = \case 85 | TyClD x tydcl -> TyClD x <$> adaptTypeOrClassDecl tydcl 86 | InstD x instdcl -> InstD x <$> adaptInstanceDecl instdcl 87 | ValD x bind -> ValD x <$> adaptTopLevelBind annotations bind 88 | -- TODO 89 | d -> pure d 90 | 91 | adaptTypeOrClassDecl :: 92 | TyClDecl GhcPs -> 93 | AdaptM (TyClDecl GhcPs) 94 | adaptTypeOrClassDecl = \case 95 | cd@ClassDecl {} -> do 96 | lbs <- adaptLBinds (tcdMeths cd) 97 | pure (cd {tcdMeths = lbs}) 98 | d -> pure d 99 | 100 | adaptInstanceDecl :: 101 | InstDecl GhcPs -> AdaptM (InstDecl GhcPs) 102 | adaptInstanceDecl = \case 103 | ClsInstD x cinstdcl -> ClsInstD x <$> adaptClassInstanceDecl cinstdcl 104 | d -> pure d 105 | 106 | adaptClassInstanceDecl :: 107 | ClsInstDecl GhcPs -> AdaptM (ClsInstDecl GhcPs) 108 | adaptClassInstanceDecl = \case 109 | cid@ClsInstDecl {} -> do 110 | lbs <- adaptLBinds (cid_binds cid) 111 | pure (cid {cid_binds = lbs}) 112 | 113 | adaptTopLevelBind :: [CoverAnnotation] -> HsBind GhcPs -> AdaptM (HsBind GhcPs) 114 | adaptTopLevelBind annotations = \case 115 | b@(FunBind _ name _) -> 116 | if DontCoverFunction (occNameString (rdrNameOcc (unLoc name))) `elem` annotations 117 | then pure b 118 | else adaptBind b 119 | -- TODO 120 | b -> pure b 121 | 122 | adaptLBinds :: LHsBinds GhcPs -> AdaptM (LHsBinds GhcPs) 123 | adaptLBinds = mapBagM adaptLBind 124 | 125 | adaptLBind :: LHsBind GhcPs -> AdaptM (LHsBind GhcPs) 126 | adaptLBind = traverse adaptBind 127 | 128 | adaptBind :: HsBind GhcPs -> AdaptM (HsBind GhcPs) 129 | adaptBind = \case 130 | FunBind x name matchGroup -> FunBind x name <$> adaptMatchGroup matchGroup 131 | -- TODO 132 | b -> pure b 133 | 134 | adaptMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> AdaptM (MatchGroup GhcPs (LHsExpr GhcPs)) 135 | adaptMatchGroup = \case 136 | MG x as -> MG x <$> traverse (mapM adaptLMatch) as 137 | 138 | adaptLMatch :: LMatch GhcPs (LHsExpr GhcPs) -> AdaptM (LMatch GhcPs (LHsExpr GhcPs)) 139 | adaptLMatch = traverse adaptMatch 140 | 141 | adaptMatch :: Match GhcPs (LHsExpr GhcPs) -> AdaptM (Match GhcPs (LHsExpr GhcPs)) 142 | adaptMatch = \case 143 | Match x ctx pats body -> Match x ctx pats <$> adaptGRHSs body 144 | 145 | adaptGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> AdaptM (GRHSs GhcPs (LHsExpr GhcPs)) 146 | adaptGRHSs = \case 147 | GRHSs x rhs localBinds -> GRHSs x <$> mapM adaptLGRHS rhs <*> adaptHsLocalBinds localBinds 148 | 149 | adaptLGRHS :: 150 | LGRHS GhcPs (LHsExpr GhcPs) -> 151 | AdaptM (LGRHS GhcPs (LHsExpr GhcPs)) 152 | adaptLGRHS = traverse adaptGRHS 153 | 154 | adaptGRHS :: GRHS GhcPs (LHsExpr GhcPs) -> AdaptM (GRHS GhcPs (LHsExpr GhcPs)) 155 | adaptGRHS = \case 156 | GRHS x guards body -> GRHS x guards <$> adaptLExpr body 157 | 158 | adaptHsLocalBinds :: HsLocalBinds GhcPs -> AdaptM (HsLocalBinds GhcPs) 159 | adaptHsLocalBinds = \case 160 | HsValBinds x valBinds -> HsValBinds x <$> adaptValBinds valBinds 161 | lbs -> pure lbs 162 | 163 | adaptValBinds :: HsValBinds GhcPs -> AdaptM (HsValBinds GhcPs) 164 | adaptValBinds = \case 165 | ValBinds x binds sigs -> ValBinds x <$> mapBagM adaptLBind binds <*> pure sigs 166 | XValBindsLR (NValBinds binds sigs) -> 167 | XValBindsLR 168 | <$> ( NValBinds 169 | <$> mapM 170 | ( \(f, s) -> 171 | (,) f <$> mapBagM adaptLBind s 172 | ) 173 | binds 174 | <*> pure sigs 175 | ) 176 | 177 | -- -- TODO 178 | -- HsValBinds x -> 179 | -- lbs -> pure lbs 180 | 181 | -- [tag:NoUniplate] 182 | -- We cannot use uniplate's method of transforming the code, because it would 183 | -- replace the middle part of infix operations by an expression that contains 184 | -- multiple pieces, and GHC (correctly) assumes that that is not possible. 185 | -- So we have to use the manual traversal. 186 | -- 187 | -- We cannot transform the middle part of an infix operator expression 188 | -- because then it would consist of more than one part. 189 | -- This would break GHC's assumption that infix operator expressions 190 | -- only consist of one part, and would cause transformations of an 191 | -- expression like 192 | -- print $ succ $ 5 193 | -- which is 194 | -- print $ (succ $ 5) 195 | -- to result in this expression: 196 | -- ((f ($)) 197 | -- ((f (($)) 198 | -- (f print) 199 | -- (f succ))) 200 | -- (f 5)) 201 | -- instead of this expression: 202 | -- ((f ($)) 203 | -- (f print) 204 | -- ((f ($)) 205 | -- (f succ) 206 | -- (f 5))) 207 | -- , which fails to parse 208 | 209 | adaptLExpr :: LHsExpr GhcPs -> AdaptM (LHsExpr GhcPs) 210 | adaptLExpr le = traverse (adaptExpr (getLocA le)) le 211 | 212 | adaptExpr :: SrcSpan -> HsExpr GhcPs -> AdaptM (HsExpr GhcPs) 213 | adaptExpr sp e = do 214 | let applyAdapter mName = case spanLocation sp of 215 | Just loc -> do 216 | addExpression 217 | Coverable 218 | { coverableValue = Dekking.Coverable.Expression {expressionIdentifier = mName}, 219 | coverableLocation = loc 220 | } 221 | applyAdapterExpr loc e 222 | Nothing -> pure e 223 | 224 | -- [ref:NoUniplate] 225 | case e of 226 | HsVar _ (L _ rdr) -> applyAdapter $ Just $ occNameString $ rdrNameOcc rdr 227 | HsUnboundVar x on -> pure $ HsUnboundVar x on 228 | HsOverLabel x s fs -> pure $ HsOverLabel x s fs 229 | HsIPVar x iv -> pure $ HsIPVar x iv 230 | HsOverLit {} -> applyAdapter Nothing 231 | HsLit {} -> applyAdapter Nothing 232 | HsLam x mg -> HsLam x <$> adaptMatchGroup mg 233 | HsLamCase x v mg -> HsLamCase x v <$> adaptMatchGroup mg 234 | HsApp x left right -> HsApp x <$> adaptLExpr left <*> adaptLExpr right 235 | -- TODO: Things inside a visible type application might be covered more 236 | -- granularly but this is quite good in the meantime. 237 | HsAppType {} -> applyAdapter Nothing 238 | OpApp x left middle right -> 239 | OpApp x 240 | <$> adaptLExpr left 241 | -- [ref:NoUniplate] 242 | <*> pure middle 243 | <*> adaptLExpr right 244 | NegApp x body se -> NegApp x <$> adaptLExpr body <*> pure se 245 | HsPar x l le r -> HsPar x l <$> adaptLExpr le <*> pure r 246 | ExplicitTuple x args boxity -> ExplicitTuple x <$> mapM adaptTupArg args <*> pure boxity 247 | ExplicitSum x ct a body -> ExplicitSum x ct a <$> adaptLExpr body 248 | HsCase x body mg -> HsCase x <$> adaptLExpr body <*> adaptMatchGroup mg 249 | HsIf x condE ifE elseE -> HsIf x <$> adaptLExpr condE <*> adaptLExpr ifE <*> adaptLExpr elseE 250 | HsLet x l lbs i body -> HsLet x l <$> adaptHsLocalBinds lbs <*> pure i <*> adaptLExpr body 251 | HsDo x ctx stmts -> HsDo x ctx <$> traverse (mapM adaptExprLStmt) stmts 252 | ExplicitList x bodies -> ExplicitList x <$> mapM adaptLExpr bodies 253 | RecordCon x name binds -> RecordCon x name <$> adaptRecordBinds binds 254 | RecordUpd x left fields -> 255 | RecordUpd x 256 | <$> adaptLExpr left 257 | <*> adaptLHsRecUpdFields fields 258 | -- TODO 259 | _ -> pure e 260 | 261 | adaptTupArg :: HsTupArg GhcPs -> AdaptM (HsTupArg GhcPs) 262 | adaptTupArg = \case 263 | Present x body -> Present x <$> adaptLExpr body 264 | Missing x -> pure $ Missing x 265 | 266 | adaptRecordBinds :: HsRecordBinds GhcPs -> AdaptM (HsRecordBinds GhcPs) 267 | adaptRecordBinds = \case 268 | HsRecFields fields md -> HsRecFields <$> mapM (traverse adaptHsRecField') fields <*> pure md 269 | 270 | adaptLHsRecUpdFields :: 271 | LHsRecUpdFields GhcPs -> AdaptM (LHsRecUpdFields GhcPs) 272 | adaptLHsRecUpdFields = \case 273 | RegularRecUpdFields x fields -> RegularRecUpdFields x <$> mapM adaptLRecordUpdateField fields 274 | OverloadedRecUpdFields x fields -> OverloadedRecUpdFields x <$> mapM adaptLRecordUpdateProjection fields 275 | 276 | adaptLRecordUpdateProjection :: LHsRecUpdProj GhcPs -> AdaptM (LHsRecUpdProj GhcPs) 277 | adaptLRecordUpdateProjection = traverse $ \case 278 | HsFieldBind ex i e b -> HsFieldBind ex i <$> adaptLExpr e <*> pure b 279 | 280 | adaptLRecordUpdateField :: LHsRecUpdField GhcPs GhcPs -> AdaptM (LHsRecUpdField GhcPs GhcPs) 281 | adaptLRecordUpdateField = traverse adaptRecordUpdateField 282 | 283 | adaptRecordUpdateField :: HsRecUpdField GhcPs GhcPs -> AdaptM (HsRecUpdField GhcPs GhcPs) 284 | adaptRecordUpdateField = \case 285 | HsFieldBind ex i e b -> HsFieldBind ex i <$> adaptLExpr e <*> pure b 286 | 287 | adaptHsRecField' :: HsRecField id (LHsExpr GhcPs) -> AdaptM (HsRecField id (LHsExpr GhcPs)) 288 | adaptHsRecField' = \case 289 | HsFieldBind ex i e b -> HsFieldBind ex i <$> adaptLExpr e <*> pure b 290 | 291 | adaptExprLStmt :: 292 | ExprLStmt GhcPs -> 293 | AdaptM (ExprLStmt GhcPs) 294 | adaptExprLStmt = traverse $ \case 295 | LastStmt x e mb se -> LastStmt x <$> adaptLExpr e <*> pure mb <*> pure se 296 | BindStmt x p e -> BindStmt x p <$> adaptLExpr e 297 | BodyStmt x e se1 se2 -> BodyStmt x <$> adaptLExpr e <*> pure se1 <*> pure se2 298 | LetStmt x lbs -> LetStmt x <$> adaptHsLocalBinds lbs 299 | s -> pure s -- TODO 300 | 301 | -- See [ref:ThePlanTM] 302 | applyAdapterExpr :: Location -> HsExpr GhcPs -> AdaptM (HsExpr GhcPs) 303 | applyAdapterExpr loc e = do 304 | moduule <- ask 305 | let strToLog = mkStringToLog moduule loc 306 | pure $ 307 | HsPar 308 | EpAnnNotUsed 309 | noHsTok 310 | ( noLocA $ 311 | HsApp 312 | EpAnnNotUsed 313 | ( noLocA 314 | ( HsApp 315 | EpAnnNotUsed 316 | (noLocA (HsVar NoExtField (noLocA (Qual adapterModuleName (mkVarOcc "adaptValue"))))) 317 | (noLocA (HsLit EpAnnNotUsed (HsString NoSourceText (mkFastString strToLog)))) 318 | ) 319 | ) 320 | (noLocA e) 321 | ) 322 | noHsTok 323 | 324 | spanLocation :: SrcSpan -> Maybe Location 325 | spanLocation sp = case sp of 326 | RealSrcSpan s _ -> 327 | Just 328 | Location 329 | { locationLine = fromIntegral (srcSpanStartLine s), 330 | locationColumnStart = fromIntegral (srcSpanStartCol s), 331 | locationColumnEnd = fromIntegral (srcSpanEndCol s) 332 | } 333 | UnhelpfulSpan _ -> Nothing 334 | 335 | mkStringToLog :: GHC.Module -> Location -> String 336 | mkStringToLog moduule loc = 337 | unwords 338 | [ unitToString (moduleUnit moduule), 339 | moduleNameString (moduleName moduule), 340 | locationString loc 341 | ] 342 | 343 | -- We drop the hash because it differs in a cabal build versus a nix build. 344 | unitToString :: GHC.Unit -> String 345 | unitToString u = 346 | case reverse . T.splitOn "-" . T.pack $ unitString u of 347 | [] -> "-" 348 | -- If there's only one component, it's probably the "main" package, and we 349 | -- still want to see this instead of drop it 350 | [x] -> T.unpack x 351 | -- If there is more than one component, the last component is the hash, so 352 | -- we drop it. 353 | (_ : rest) -> T.unpack $ T.intercalate "-" $ reverse rest 354 | -------------------------------------------------------------------------------- /dekking-report/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /dekking-report/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Dekking.Report 4 | 5 | main :: IO () 6 | main = reportMain 7 | -------------------------------------------------------------------------------- /dekking-report/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, aeson-pretty, autodocodec, base, blaze-html 2 | , bytestring, containers, dekking-plugin, lib, optparse-applicative 3 | , path, path-io, shakespeare, text 4 | }: 5 | mkDerivation { 6 | pname = "dekking-report"; 7 | version = "0.0.0.0"; 8 | src = ./.; 9 | isLibrary = true; 10 | isExecutable = true; 11 | libraryHaskellDepends = [ 12 | aeson aeson-pretty autodocodec base blaze-html bytestring 13 | containers dekking-plugin optparse-applicative path path-io 14 | shakespeare text 15 | ]; 16 | executableHaskellDepends = [ base ]; 17 | homepage = "https://github.com/NorfairKing/dekking#readme"; 18 | license = "unknown"; 19 | mainProgram = "dekking-report"; 20 | } 21 | -------------------------------------------------------------------------------- /dekking-report/dekking-report.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: dekking-report 8 | version: 0.0.0.0 9 | homepage: https://github.com/NorfairKing/dekking#readme 10 | bug-reports: https://github.com/NorfairKing/dekking/issues 11 | author: Tom Sydney Kerckhove 12 | maintainer: Tom Sydney Kerckhove 13 | build-type: Simple 14 | extra-source-files: 15 | templates/index.hamlet 16 | templates/module.hamlet 17 | templates/package.hamlet 18 | templates/progress-bar.hamlet 19 | templates/script.julius 20 | templates/style.lucius 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/NorfairKing/dekking 25 | 26 | library 27 | exposed-modules: 28 | Dekking.Coverage 29 | Dekking.OptParse 30 | Dekking.Report 31 | other-modules: 32 | Paths_dekking_report 33 | hs-source-dirs: 34 | src 35 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages 36 | build-depends: 37 | aeson 38 | , aeson-pretty 39 | , autodocodec 40 | , base >=4.7 && <5 41 | , blaze-html 42 | , bytestring 43 | , containers 44 | , dekking-plugin 45 | , optparse-applicative 46 | , path 47 | , path-io 48 | , shakespeare 49 | , text 50 | default-language: Haskell2010 51 | 52 | executable dekking-report 53 | main-is: Main.hs 54 | other-modules: 55 | Paths_dekking_report 56 | hs-source-dirs: 57 | app 58 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -optP-Wno-nonportable-include-path 59 | build-depends: 60 | base >=4.7 && <5 61 | , dekking-report 62 | default-language: Haskell2010 63 | -------------------------------------------------------------------------------- /dekking-report/package.yaml: -------------------------------------------------------------------------------- 1 | name: dekking-report 2 | version: 0.0.0.0 3 | github: "NorfairKing/dekking" 4 | author: "Tom Sydney Kerckhove" 5 | 6 | dependencies: 7 | - base >= 4.7 && < 5 8 | 9 | extra-source-files: 10 | - templates/**/* 11 | 12 | ghc-options: 13 | - -Wall 14 | - -Widentities 15 | - -Wincomplete-record-updates 16 | - -Wincomplete-uni-patterns 17 | - -Wmissing-home-modules 18 | - -Wpartial-fields 19 | - -Wredundant-constraints 20 | 21 | library: 22 | source-dirs: src 23 | ghc-options: 24 | # This must be put here and not lower because the tests use the plugin and 25 | # ghc detects that dekking-value is unused despite an import being generated 26 | # by the plugin. 27 | - -Wunused-packages 28 | dependencies: 29 | - aeson 30 | - aeson-pretty 31 | - autodocodec 32 | - blaze-html 33 | - bytestring 34 | - containers 35 | - dekking-plugin 36 | - optparse-applicative 37 | - path 38 | - path-io 39 | - shakespeare 40 | - text 41 | 42 | executables: 43 | dekking-report: 44 | main: Main.hs 45 | source-dirs: app 46 | ghc-options: 47 | - -threaded 48 | - -rtsopts 49 | - -optP-Wno-nonportable-include-path # For macos 50 | dependencies: 51 | - dekking-report 52 | -------------------------------------------------------------------------------- /dekking-report/src/Dekking/Coverage.hs: -------------------------------------------------------------------------------- 1 | module Dekking.Coverage where 2 | 3 | import Data.Maybe 4 | import Data.Set (Set) 5 | import qualified Data.Set as S 6 | import Dekking.Coverable 7 | import Path 8 | import Text.Read 9 | 10 | readCoverageFiles :: Set (Path Abs File) -> IO (Set (PackageName, ModuleName, Location)) 11 | readCoverageFiles = foldMap (\f -> print f >> readCoverageFile f) 12 | 13 | readCoverageFile :: Path Abs File -> IO (Set (PackageName, ModuleName, Location)) 14 | readCoverageFile p = S.fromList . mapMaybe parseIdentifier . lines <$> readFile (fromAbsFile p) 15 | 16 | parseIdentifier :: String -> Maybe (PackageName, ModuleName, Location) 17 | parseIdentifier str = 18 | case words str of 19 | [] -> Nothing 20 | [x, y, ls, ss, es] -> do 21 | l <- readMaybe ls 22 | s <- readMaybe ss 23 | e <- readMaybe es 24 | Just (x, y, Location {locationLine = l, locationColumnStart = s, locationColumnEnd = e}) 25 | _ -> Nothing 26 | -------------------------------------------------------------------------------- /dekking-report/src/Dekking/OptParse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Dekking.OptParse 6 | ( getSettings, 7 | Settings (..), 8 | ) 9 | where 10 | 11 | import Control.Applicative 12 | import Data.Set (Set) 13 | import qualified Data.Set as S 14 | import GHC.Generics (Generic) 15 | import Options.Applicative as OptParse 16 | import Path 17 | import Path.IO 18 | 19 | getSettings :: IO Settings 20 | getSettings = getFlags >>= combineToSettings 21 | 22 | data Settings = Settings 23 | { settingCoverablesDirs :: !(Set (Path Abs Dir)), 24 | settingCoverageFiles :: !(Set (Path Abs File)), 25 | settingOutputDir :: !(Path Abs Dir) 26 | } 27 | deriving (Show, Eq, Generic) 28 | 29 | combineToSettings :: Flags -> IO Settings 30 | combineToSettings Flags {..} = do 31 | settingCoverablesDirs <- S.fromList <$> mapM resolveDir' flagCoverablesDirs 32 | settingCoverageFiles <- S.fromList <$> mapM resolveFile' flagCoverageFiles 33 | settingOutputDir <- maybe getCurrentDir resolveDir' flagOutputDir 34 | pure Settings {..} 35 | 36 | getFlags :: IO Flags 37 | getFlags = customExecParser prefs_ parseFlags 38 | 39 | prefs_ :: OptParse.ParserPrefs 40 | prefs_ = 41 | OptParse.defaultPrefs 42 | { OptParse.prefShowHelpOnError = True, 43 | OptParse.prefShowHelpOnEmpty = True 44 | } 45 | 46 | data Flags = Flags 47 | { flagCoverablesDirs :: ![FilePath], 48 | flagCoverageFiles :: ![FilePath], 49 | flagOutputDir :: !(Maybe FilePath) 50 | } 51 | deriving (Show, Eq, Generic) 52 | 53 | parseFlags :: OptParse.ParserInfo Flags 54 | parseFlags = OptParse.info parser modifier 55 | where 56 | modifier = OptParse.fullDesc <> OptParse.progDesc "Produce a coverage report" 57 | parser = 58 | Flags 59 | <$> many 60 | ( strOption 61 | ( mconcat 62 | [ long "coverables", 63 | help "A directory with coverables", 64 | metavar "DIRECTORY", 65 | completer $ bashCompleter "directory" 66 | ] 67 | ) 68 | ) 69 | <*> many 70 | ( strOption 71 | ( mconcat 72 | [ long "coverage", 73 | help "A coverage file", 74 | metavar "FILE", 75 | completer $ bashCompleter "file" 76 | ] 77 | ) 78 | ) 79 | <*> optional 80 | ( strOption 81 | ( mconcat 82 | [ long "output", 83 | help "Output directory", 84 | metavar "DIRECTORY", 85 | completer $ bashCompleter "directory" 86 | ] 87 | ) 88 | ) 89 | -------------------------------------------------------------------------------- /dekking-report/src/Dekking/Report.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Dekking.Report (reportMain, computeCoverageReport, computeModuleCoverageReport) where 8 | 9 | import Autodocodec 10 | import Control.Arrow (second) 11 | import Control.Monad 12 | import Data.Aeson (FromJSON, ToJSON) 13 | import Data.Aeson.Encode.Pretty (encodePretty) 14 | import qualified Data.ByteString as SB 15 | import qualified Data.ByteString.Lazy as LB 16 | import Data.Map (Map) 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | import Data.Set (Set) 20 | import qualified Data.Set as S 21 | import Data.Text (Text) 22 | import qualified Data.Text as T 23 | import qualified Data.Text.Encoding as TE 24 | import qualified Data.Text.Lazy as LT 25 | import Dekking.Coverable 26 | import Dekking.Coverage 27 | import Dekking.OptParse 28 | import Path 29 | import Path.IO 30 | import Text.Blaze.Html.Renderer.Utf8 as Blaze 31 | import Text.Hamlet 32 | import Text.Julius 33 | import Text.Lucius 34 | import Text.Printf 35 | 36 | reportMain :: IO () 37 | reportMain = do 38 | Settings {..} <- getSettings 39 | 40 | coverables <- readCoverablesFiles settingCoverablesDirs 41 | coverage <- readCoverageFiles settingCoverageFiles 42 | 43 | let coverageReport = computeCoverageReport coverables coverage 44 | 45 | ensureDir settingOutputDir 46 | 47 | jsonFile <- resolveFile settingOutputDir (renderReportFile JSONFile) 48 | SB.writeFile (fromAbsFile jsonFile) (LB.toStrict (encodePretty coverageReport)) 49 | 50 | styleFile <- resolveFile settingOutputDir (renderReportFile StyleFile) 51 | SB.writeFile (fromAbsFile styleFile) $ TE.encodeUtf8 coverageReportCss 52 | 53 | scriptFile <- resolveFile settingOutputDir (renderReportFile ScriptFile) 54 | SB.writeFile (fromAbsFile scriptFile) $ TE.encodeUtf8 coverageReportJS 55 | 56 | reportFile <- resolveFile settingOutputDir (renderReportFile IndexFile) 57 | SB.writeFile (fromAbsFile reportFile) $ LB.toStrict $ Blaze.renderHtml $ htmlCoverageReport coverageReport 58 | 59 | forM_ (M.toList (coverageReportModules coverageReport)) $ \(pn, m) -> do 60 | packagePath <- resolveFile settingOutputDir (renderReportFile (PackageFile pn)) 61 | ensureDir (parent packagePath) 62 | SB.writeFile (fromAbsFile packagePath) $ 63 | LB.toStrict $ 64 | Blaze.renderHtml $ 65 | htmlPackageCoverageReport pn m 66 | 67 | forM_ (concatMap (\(pn, mn) -> (,) pn <$> M.toList mn) (M.toList (coverageReportModules coverageReport))) $ \(pn, (mn, mc)) -> do 68 | modulePath <- resolveFile settingOutputDir (renderReportFile (ModuleFile pn mn)) 69 | ensureDir (parent modulePath) 70 | SB.writeFile (fromAbsFile modulePath) $ 71 | LB.toStrict $ 72 | Blaze.renderHtml $ 73 | htmlModuleCoverageReport pn mn mc 74 | 75 | data ReportFile 76 | = JSONFile 77 | | StyleFile 78 | | ScriptFile 79 | | IndexFile 80 | | PackageFile !PackageName 81 | | ModuleFile !PackageName !ModuleName 82 | 83 | renderReportFile :: ReportFile -> FilePath 84 | renderReportFile = \case 85 | JSONFile -> "report.json" 86 | StyleFile -> "style.css" 87 | ScriptFile -> "script.js" 88 | IndexFile -> "index.html" 89 | PackageFile pn -> packageFileName pn 90 | ModuleFile pn mn -> moduleFileName pn mn 91 | 92 | packageFileName :: PackageName -> FilePath 93 | packageFileName pn = pn <> ".html" 94 | 95 | moduleFileName :: PackageName -> ModuleName -> FilePath 96 | moduleFileName pn mn = pn <> mn <> ".html" 97 | 98 | reportUrlRender :: ReportFile -> [(Text, Text)] -> Text 99 | reportUrlRender rf _ = T.pack $ renderReportFile rf 100 | 101 | coverageReportCss :: Text 102 | coverageReportCss = LT.toStrict $ renderCss $ $(luciusFile "templates/style.lucius") reportUrlRender 103 | 104 | coverageReportJS :: Text 105 | coverageReportJS = LT.toStrict $ renderJavascript $ $(juliusFile "templates/script.julius") reportUrlRender 106 | 107 | htmlCoverageReport :: CoverageReport -> Html 108 | htmlCoverageReport CoverageReport {..} = 109 | let unwrapped = concatMap (\(pn, ms) -> (,) pn <$> M.toList ms) (M.toList coverageReportModules) 110 | summaries = map (second (second (\ModuleCoverageReport {..} -> computeCoverageSummary moduleCoverageReportExpressions))) unwrapped 111 | totalExpressionSummary = foldMap (snd . snd) summaries 112 | in $(hamletFile "templates/index.hamlet") reportUrlRender 113 | 114 | htmlPackageCoverageReport :: PackageName -> Map ModuleName ModuleCoverageReport -> Html 115 | htmlPackageCoverageReport packageName moduleCoverageReports = 116 | let summaries = map (second (\ModuleCoverageReport {..} -> computeCoverageSummary moduleCoverageReportExpressions)) (M.toList moduleCoverageReports) 117 | totalExpressionSummary = foldMap snd summaries 118 | in $(hamletFile "templates/package.hamlet") reportUrlRender 119 | 120 | htmlModuleCoverageReport :: PackageName -> ModuleName -> ModuleCoverageReport -> Html 121 | htmlModuleCoverageReport packageName moduleName ModuleCoverageReport {..} = 122 | let annotatedLines = zip [(1 :: Word) ..] (unAnnotatedSource moduleCoverageReportAnnotatedSource) 123 | expressionSummary = computeCoverageSummary moduleCoverageReportExpressions 124 | in $(hamletFile "templates/module.hamlet") reportUrlRender 125 | 126 | coveredCaseClass :: Covered -> Maybe String 127 | coveredCaseClass = \case 128 | Covered -> Just coveredClass 129 | Uncovered -> Just uncoveredClass 130 | Uncoverable -> Nothing 131 | 132 | coveredClass :: String 133 | coveredClass = "covered" 134 | 135 | uncoveredClass :: String 136 | uncoveredClass = "uncovered" 137 | 138 | coveredColour :: String 139 | coveredColour = "#00aa00" 140 | 141 | uncoveredColour :: String 142 | uncoveredColour = "yellow" 143 | 144 | computeCoverageReport :: Coverables -> Set (PackageName, ModuleName, Location) -> CoverageReport 145 | computeCoverageReport Coverables {..} coverage = 146 | CoverageReport $ 147 | M.mapWithKey 148 | ( \packageName modules -> 149 | M.mapWithKey 150 | ( \moduleName (sourceCode, moduleCoverables) -> 151 | let relevantCoverage = 152 | S.fromList 153 | . mapMaybe 154 | ( \(pn, mm, tlb) -> 155 | if pn == packageName && mm == moduleName 156 | then Just tlb 157 | else Nothing 158 | ) 159 | . S.toList 160 | $ coverage 161 | in computeModuleCoverageReport sourceCode moduleCoverables relevantCoverage 162 | ) 163 | modules 164 | ) 165 | coverablesModules 166 | 167 | newtype CoverageReport = CoverageReport {coverageReportModules :: Map PackageName (Map ModuleName ModuleCoverageReport)} 168 | deriving (Show, Eq) 169 | deriving (FromJSON, ToJSON) via (Autodocodec CoverageReport) 170 | 171 | instance HasCodec CoverageReport where 172 | codec = dimapCodec CoverageReport coverageReportModules codec 173 | 174 | computeModuleCoverageReport :: String -> ModuleCoverables -> Set Location -> ModuleCoverageReport 175 | computeModuleCoverageReport sourceCode ModuleCoverables {..} covereds = 176 | let expressionCoverage = computeCoverage moduleCoverablesExpressions covereds 177 | in ModuleCoverageReport 178 | { moduleCoverageReportAnnotatedSource = produceAnnotatedSource sourceCode expressionCoverage, 179 | moduleCoverageReportExpressions = expressionCoverage 180 | } 181 | 182 | data ModuleCoverageReport = ModuleCoverageReport 183 | { moduleCoverageReportAnnotatedSource :: AnnotatedSource, 184 | moduleCoverageReportExpressions :: Coverage Expression 185 | } 186 | deriving (Show, Eq) 187 | deriving (FromJSON, ToJSON) via (Autodocodec ModuleCoverageReport) 188 | 189 | instance HasCodec ModuleCoverageReport where 190 | codec = 191 | object "ModuleCoverageReport" $ 192 | ModuleCoverageReport 193 | <$> requiredField "annotated-source" "annotated source" .= moduleCoverageReportAnnotatedSource 194 | <*> requiredField "expressions" "expressions" .= moduleCoverageReportExpressions 195 | 196 | data Coverage a = Coverage 197 | { coverageCovered :: Set (Coverable a), 198 | coverageUncovered :: Set (Coverable a) 199 | } 200 | deriving (Show, Eq, Ord) 201 | 202 | instance (Ord a) => Semigroup (Coverage a) where 203 | (<>) c1 c2 = 204 | Coverage 205 | { coverageCovered = coverageCovered c1 <> coverageCovered c2, 206 | coverageUncovered = coverageUncovered c1 <> coverageUncovered c2 207 | } 208 | 209 | instance (Ord a, HasCodec a) => HasCodec (Coverage a) where 210 | codec = 211 | object "Coverage" $ 212 | Coverage 213 | <$> requiredField "covered" "covered values" .= coverageCovered 214 | <*> requiredField "uncovered" "uncovered values" .= coverageUncovered 215 | 216 | computeCoverage :: Set (Coverable a) -> Set Location -> Coverage a 217 | computeCoverage coverables covereds = 218 | Coverage 219 | { coverageCovered = S.filter ((`S.member` covereds) . coverableLocation) coverables, 220 | coverageUncovered = S.filter (not . (`S.member` covereds) . coverableLocation) coverables 221 | } 222 | 223 | data CoverageSummary = CoverageSummary 224 | { coverageSummaryUncovered :: !Word, 225 | coverageSummaryCovered :: !Word 226 | } 227 | deriving (Show, Eq, Ord) 228 | 229 | computeCoverageSummary :: Coverage a -> CoverageSummary 230 | computeCoverageSummary Coverage {..} = 231 | let coverageSummaryUncovered = fromIntegral $ S.size coverageUncovered 232 | coverageSummaryCovered = fromIntegral $ S.size coverageCovered 233 | in CoverageSummary {..} 234 | 235 | coverageSummaryTotal :: CoverageSummary -> Word 236 | coverageSummaryTotal CoverageSummary {..} = coverageSummaryUncovered + coverageSummaryCovered 237 | 238 | coverageSummaryRatio :: CoverageSummary -> Float 239 | coverageSummaryRatio cs = fromIntegral (coverageSummaryCovered cs) / fromIntegral (coverageSummaryTotal cs) 240 | 241 | coverageSummaryPercentage :: CoverageSummary -> String 242 | coverageSummaryPercentage cs = printf "%.0f" (100 * coverageSummaryRatio cs) 243 | 244 | instance Semigroup CoverageSummary where 245 | (<>) c1 c2 = 246 | CoverageSummary 247 | { coverageSummaryUncovered = coverageSummaryUncovered c1 + coverageSummaryUncovered c2, 248 | coverageSummaryCovered = coverageSummaryCovered c1 + coverageSummaryCovered c2 249 | } 250 | 251 | instance Monoid CoverageSummary where 252 | mempty = 253 | CoverageSummary 254 | { coverageSummaryUncovered = 0, 255 | coverageSummaryCovered = 0 256 | } 257 | mappend = (<>) 258 | 259 | newtype AnnotatedSource = AnnotatedSource {unAnnotatedSource :: [[(String, Covered)]]} 260 | deriving (Show, Eq) 261 | 262 | instance HasCodec AnnotatedSource where 263 | codec = 264 | dimapCodec AnnotatedSource unAnnotatedSource $ 265 | listCodec 266 | ( listCodec 267 | ( object "Annotated" $ 268 | (,) 269 | <$> requiredField "source" "source" .= fst 270 | <*> requiredField "annotation" "annotation" .= snd 271 | ) 272 | ) 273 | 274 | data Covered = Covered | Uncovered | Uncoverable 275 | deriving (Show, Read, Eq, Ord, Bounded, Enum) 276 | 277 | instance HasCodec Covered where 278 | codec = shownBoundedEnumCodec 279 | 280 | produceAnnotatedSource :: String -> Coverage a -> AnnotatedSource 281 | produceAnnotatedSource source coverage = 282 | let ls = lines source 283 | in AnnotatedSource $ 284 | flip map (zip [1 ..] ls) $ \(lineNum, line) -> 285 | case M.lookup lineNum (produceIntervals coverage) of 286 | Nothing -> [(line, Uncoverable)] 287 | Just lineCoverage -> go 1 line (S.toAscList lineCoverage) 288 | where 289 | go :: Word -> String -> [((Word, Word), Covered)] -> [(String, Covered)] 290 | go _ [] _ = [] 291 | go _ rest [] = [(rest, Uncoverable)] 292 | go ix s (((start, end), c) : rest) = 293 | let (before, afterStart) = splitAt (fromIntegral (start - ix)) s 294 | (middle, after) = splitAt (fromIntegral (end - start)) afterStart 295 | in (before, Uncoverable) : (middle, c) : go end after rest 296 | 297 | produceIntervals :: Coverage a -> Map Word (Set ((Word, Word), Covered)) 298 | produceIntervals Coverage {..} = go Covered coverageCovered $ go Uncovered coverageUncovered M.empty 299 | where 300 | go :: Covered -> Set (Coverable a) -> Map Word (Set ((Word, Word), Covered)) -> Map Word (Set ((Word, Word), Covered)) 301 | 302 | go c s m = 303 | S.foldl 304 | ( \acc Coverable {..} -> 305 | let Location {..} = coverableLocation 306 | in M.insertWith 307 | S.union 308 | locationLine 309 | (S.singleton ((locationColumnStart, locationColumnEnd), c)) 310 | acc 311 | ) 312 | m 313 | s 314 | 315 | mkProgressBar :: CoverageSummary -> Html 316 | mkProgressBar coverageSummary = 317 | let bothZero = coverageSummaryCovered coverageSummary == 0 && coverageSummaryTotal coverageSummary == 0 318 | val = if bothZero then 1 else coverageSummaryCovered coverageSummary 319 | mx = if bothZero then 1 else coverageSummaryTotal coverageSummary 320 | in $(hamletFile "templates/progress-bar.hamlet") (error "unused") 321 | -------------------------------------------------------------------------------- /dekking-report/templates/index.hamlet: -------------------------------------------------------------------------------- 1 | $doctype 5 2 | 3 | 4 | 5 | 6 |

7 | Coverage report 8 | 9 | 10 | 11 | 12 | 25 | $forall (packageName, (moduleName, expressionSummary)) <- summaries 26 | 27 | 44 | 45 |
13 | Package 14 | 15 | Module 16 | 17 | Covered 18 | 19 | Total 20 | 21 | Percentage 22 | 23 | Expressions 24 |
28 | 29 | 30 | #{packageName} 31 | 32 | 33 | 34 | #{moduleName} 35 | 36 | #{coverageSummaryCovered expressionSummary} 37 | 38 | #{coverageSummaryTotal expressionSummary} 39 | 40 | #{coverageSummaryPercentage expressionSummary} 41 | 42 | #{mkProgressBar expressionSummary} 43 |
46 | Total 47 | 48 | 49 | #{coverageSummaryCovered totalExpressionSummary} 50 | 51 | #{coverageSummaryTotal totalExpressionSummary} 52 | 53 | #{coverageSummaryPercentage totalExpressionSummary} 54 | 55 | #{mkProgressBar totalExpressionSummary} 56 | 57 |