inspection-testing-0.4.2.1/0000755000000000000000000000000013476412656013706 5ustar0000000000000000inspection-testing-0.4.2.1/Setup.hs0000644000000000000000000000005613476412656015343 0ustar0000000000000000import Distribution.Simple main = defaultMain inspection-testing-0.4.2.1/README.md0000644000000000000000000000621013476412656015164 0ustar0000000000000000Inspection Testing for Haskell ============================== This GHC plugin allows you to embed assertions about the intermediate code into your Haskell code, and have them checked by GHC. This is called _inspection testing_ (as it automates what you do when you manually inspect the intermediate code). Synopsis -------- See the `Test.Inspection` module for the documentation, but there really isn't much more to it than: ```haskell {-# LANGUAGE TemplateHaskell #-} module Simple where import Test.Inspection import Data.Maybe lhs, rhs :: (a -> b) -> Maybe a -> Bool lhs f x = isNothing (fmap f x) rhs f Nothing = True rhs f (Just _) = False inspect $ 'lhs === 'rhs ``` If you compile this, you will reassurringly read: ``` $ ghc Simple.hs [1 of 1] Compiling Simple ( Simple.hs, Simple.o ) examples/Simple.hs:14:1: lhs === rhs passed. inspection testing successful expected successes: 1 ``` See the [`examples/`](examples/) directory for more examples of working proofs. If an assertion fails, for example ```haskell bad1, bad2 :: Int bad1 = 2 + 2 bad2 = 5 inspect $ 'bad1 === 'bad2 ``` then the compiler will tell you so, and abort the compilation: ``` $ ghc Simple.hs -dsuppress-idinfo [5 of 5] Compiling Simple ( examples/Simple.hs, examples/Simple.o ) examples/Simple.hs:14:1: lhs === rhs passed. examples/Simple.hs:20:1: bad1 === bad2 failed: LHS: bad1 :: Int bad1 = I# 4# RHS: bad2 :: Int bad2 = I# 5# examples/Simple.hs: error: inspection testing unsuccessful expected successes: 1 unexpected failures: 1 ``` What can I check for? --------------------- Currently, inspection-testing supports * checking two definitions to be equal (useful in the context of generic programming) * checking the absence of a certain type (useful in the context of list or stream fusion) * checking the absence of a a use of certian functions * checking the absence of allocation (generally useful) * checking the absence of typeclass-overloaded code In general, the checks need to be placed in the same module as the checked-definition. Possible further applications includes * checking that all recursive functions are (efficiently called) join-points * asserting strictness properties (e.g. in `Data.Map.Strict`) * peforming some of these checks only within recursive loops Let me know if you need any of these, or have further ideas. Help, I am drowning in Core! ---------------------------- inspection-testing prints the Core more or less like GHC would, and the same flags can be used to control the level of detail. In particular, you might want to pass to GHC a selection of the following flags: -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures -dsuppress-uniques It does not seem to do anything (on GHC < 8.4) ---------------------------------------------- Add this line to your module: {-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-} Can I comment or help? ---------------------- Sure! We can use the GitHub issue tracker for discussions, and obviously contributions are welcome. inspection-testing-0.4.2.1/LICENSE0000644000000000000000000000204413476412656014713 0ustar0000000000000000Copyright (c) 2017 Joachim Breitner Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 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. 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. inspection-testing-0.4.2.1/ChangeLog.md0000644000000000000000000000427613476412656016070 0ustar0000000000000000# Revision history for inspection-testing ## 0.4.2.1 -- 2019-06-07 * Bugfix release ## 0.4.2 -- 2019-06-05 * Be less picky if mutually recursive definitions appear in a different order in the source * Add obligation `coreOf`, which succeeds, but lets you dump the core of a single symbol (thanks to @phadej) * Support `-fplugin-opt=Test.Inspection.Plugin:keep-going-O0` (thanks to @phadej) ## 0.4.1.2 -- 2019-02-23 * Do not force recompilation with GHC >= 8.6 * Support `-fplugin-opt=Test.Inspection.Plugin:quiet` ## 0.4.1.1 -- 2018-11-17 * Fix a bug with `doesNotUse` and data constructors ## 0.4.1 -- 2018-11-17 * New obligation `doesNotUse` * Use the Obligation’s testName in the plugin output. * In `inspect`, do not override `srcLoc` if already present. ## 0.4 -- 2018-10-12 * Support GHC-8.6 * On GHC-8.4 or newer, `inspect` and `inspectTest` will automatically load the plugin. ## 0.3 -- 2018-07-07 * On GHC-8.5 or newer, use of `inspect` or `inspectTest` without actually loading the plugin will cause compilation to fail at type-checking time (thanks to @adamgundry for the idea) * Support for `hasNoTypeClass` (thanks to @phadej) * Support for `hasNoGenerics` (thanks to @isovector) * No need to keep referenced variables alive using annotations: Simply mentioning them in a Template Haskell splice keeps them alive! ## 0.2.0.1 -- 2018-02-02 * Support GHC HEAD (8.5) ## 0.2 -- 2018-01-17 * With `$(inspectTest obligation)` you can now get the result of inspection testing at run-time, for integration into your test suite. ## 0.1.2 -- 2017-11-20 * Make `(==-)` a bit more liberal, and look through variable redefinitions that only change the type ## 0.1.1.2 -- 2017-11-12 * Hotfix: Do not abort if there are expected failures ## 0.1.1.1 -- 2017-11-12 * Show summary stats * Pull in less tests, to make inclusion in stackage easier ## 0.1.1 -- 2017-11-09 * More complete output when `(===)` fails * Variant `(==-)` that ignores types when comparing terms ## 0.1 -- 2017-11-09 * Repackaged as inspection-testing ## 0.1.1 -- 2017-09-05 * Also run simplifier in stage 0 ## 0.1 -- 2017-08-26 * Initial release to hackage ## 0 -- 2017-02-06 * Development of ghc-proofs commences inspection-testing-0.4.2.1/inspection-testing.cabal0000644000000000000000000001545613476412656020533 0ustar0000000000000000name: inspection-testing version: 0.4.2.1 synopsis: GHC plugin to do inspection testing description: Some carefully crafted libraries make promises to their users beyond functionality and performance. . Examples are: Fusion libraries promise intermediate data structures to be eliminated. Generic programming libraries promise that the generic implementation is identical to the hand-written one. Some libraries may promise allocation-free or branch-free code. . Conventionally, the modus operandi in all these cases is that the library author manually inspects the (intermediate or final) code produced by the compiler. This is not only tedious, but makes it very likely that some change, either in the library itself or the surrounding eco-system, breaks the library’s promised without anyone noticing. . This package provides a disciplined way of specifying such properties, and have them checked by the compiler. This way, this checking can be part of the ususal development cycle and regressions caught early. . See the documentation in "Test.Inspection" or the project webpage for more examples and more information. category: Testing, Compiler Plugin homepage: https://github.com/nomeata/inspection-testing license: MIT license-file: LICENSE author: Joachim Breitner maintainer: mail@joachim-breitner.de copyright: 2017 Joachim Breitner build-type: Simple extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 Tested-With: GHC == 8.0.2, GHC == 8.2.*, GHC == 8.4.*, GHC ==8.6.* source-repository head type: git location: git://github.com/nomeata/inspection-testing.git library exposed-modules: Test.Inspection Test.Inspection.Plugin Test.Inspection.Core hs-source-dirs: src build-depends: base >=4.9 && <4.13 build-depends: ghc >= 8.0.2 && <8.7 build-depends: template-haskell build-depends: containers build-depends: transformers build-depends: mtl default-language: Haskell2010 ghc-options: -Wall -Wno-name-shadowing test-suite NS_NP type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: NS_NP.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is NS_NP if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite simple type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Simple.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Simple if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite simple-test type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: SimpleTest.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite doesnotuse type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: DoesNotUse.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is DoesNotUse if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite fusion type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Fusion.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Fusion if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite generics type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Generics.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Generics if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite dictionary type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Dictionary.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is Dictionary if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin flag more-tests description: Run tests that pull in specific versions of other packages default: False test-suite text type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Text.hs if flag(more-tests) build-depends: inspection-testing build-depends: base >=4.9 && <4.13 build-depends: text ==1.2.2.2 build-depends: bytestring else buildable: False default-language: Haskell2010 ghc-options: -main-is Text if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite generic-lens type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: GenericLens.hs if flag(more-tests) build-depends: inspection-testing build-depends: base >=4.9 && <4.13 build-depends: generic-lens ==0.4.1.0 else buildable: False default-language: Haskell2010 ghc-options: -main-is GenericLens if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite mutual-recursion type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: MutualRecursion.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 ghc-options: -main-is MutualRecursion test-suite regression type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Regression.hs build-depends: inspection-testing build-depends: base >=4.9 && <4.13 default-language: Haskell2010 if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin inspection-testing-0.4.2.1/examples/0000755000000000000000000000000013476412656015524 5ustar0000000000000000inspection-testing-0.4.2.1/examples/MutualRecursion.hs0000644000000000000000000005644613476412656021240 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} module MutualRecursion where import System.Exit import Test.Inspection inf = go0 where go0 = 'a' : go1 go1 = 'b' : go2 go2 = 'c' : go0 inf' = go0 where go1 = 'b' : go2 go0 = 'a' : go1 go2 = 'c' : go0 inf2' = go0 where go1 = 'b' : go2 go2 = 'c' : go0 go0 = 'a' : go1 inf3' = go0 where go0 = 'a' : go1 go1 = 'b' : go2 go2 = 'c' : go0 inspect $ 'inf === 'inf' inspect $ 'inf === 'inf2' inspect $ 'inf === 'inf3' letrec = let go0 = 'a' : go1 go1 = 'b' : go2 go2 = 'c' : go0 in go0 letrec' = let go1 = 'b' : go2 go0 = 'a' : go1 go2 = 'c' : go0 in go0 letrec2' = let go1 = 'b' : go2 go2 = 'c' : go0 go0 = 'a' : go1 in go0 letrec3' = let go0 = 'a' : go1 go1 = 'b' : go2 go2 = 'c' : go0 in go0 inspect $ 'letrec === 'letrec' inspect $ 'letrec === 'letrec2' inspect $ 'letrec === 'letrec3' something_else = let go0 = 'a' : go1 go1 = 'b' : go0 go2 = 'c' : go0 in go0 inspect $ 'letrec =/= 'something_else -- | Test to make sure we don't have any aggressively worst-case behavior. bigletrec = let go0 = '\x0' : go1 go1 = '\x1' : go2 go2 = '\x2' : go3 go3 = '\x3' : go4 go4 = '\x4' : go5 go5 = '\x5' : go6 go6 = '\x6' : go7 go7 = '\x7' : go8 go8 = '\x8' : go9 go9 = '\x9' : go10 go10 = '\x10' : go11 go11 = '\x11' : go12 go12 = '\x12' : go13 go13 = '\x13' : go14 go14 = '\x14' : go15 go15 = '\x15' : go16 go16 = '\x16' : go17 go17 = '\x17' : go18 go18 = '\x18' : go19 go19 = '\x19' : go20 go20 = '\x20' : go21 go21 = '\x21' : go22 go22 = '\x22' : go23 go23 = '\x23' : go24 go24 = '\x24' : go25 go25 = '\x25' : go26 go26 = '\x26' : go27 go27 = '\x27' : go28 go28 = '\x28' : go29 go29 = '\x29' : go30 go30 = '\x30' : go31 go31 = '\x31' : go32 go32 = '\x32' : go33 go33 = '\x33' : go34 go34 = '\x34' : go35 go35 = '\x35' : go36 go36 = '\x36' : go37 go37 = '\x37' : go38 go38 = '\x38' : go39 go39 = '\x39' : go40 go40 = '\x40' : go41 go41 = '\x41' : go42 go42 = '\x42' : go43 go43 = '\x43' : go44 go44 = '\x44' : go45 go45 = '\x45' : go46 go46 = '\x46' : go47 go47 = '\x47' : go48 go48 = '\x48' : go49 go49 = '\x49' : go50 go50 = '\x50' : go51 go51 = '\x51' : go52 go52 = '\x52' : go53 go53 = '\x53' : go54 go54 = '\x54' : go55 go55 = '\x55' : go56 go56 = '\x56' : go57 go57 = '\x57' : go58 go58 = '\x58' : go59 go59 = '\x59' : go60 go60 = '\x60' : go61 go61 = '\x61' : go62 go62 = '\x62' : go63 go63 = '\x63' : go64 go64 = '\x64' : go65 go65 = '\x65' : go66 go66 = '\x66' : go67 go67 = '\x67' : go68 go68 = '\x68' : go69 go69 = '\x69' : go70 go70 = '\x70' : go71 go71 = '\x71' : go72 go72 = '\x72' : go73 go73 = '\x73' : go74 go74 = '\x74' : go75 go75 = '\x75' : go76 go76 = '\x76' : go77 go77 = '\x77' : go78 go78 = '\x78' : go79 go79 = '\x79' : go80 go80 = '\x80' : go81 go81 = '\x81' : go82 go82 = '\x82' : go83 go83 = '\x83' : go84 go84 = '\x84' : go85 go85 = '\x85' : go86 go86 = '\x86' : go87 go87 = '\x87' : go88 go88 = '\x88' : go89 go89 = '\x89' : go90 go90 = '\x90' : go91 go91 = '\x91' : go92 go92 = '\x92' : go93 go93 = '\x93' : go94 go94 = '\x94' : go95 go95 = '\x95' : go96 go96 = '\x96' : go97 go97 = '\x97' : go98 go98 = '\x98' : go99 go99 = '\x99' : go100 go100 = '\x100' : go101 go101 = '\x101' : go102 go102 = '\x102' : go103 go103 = '\x103' : go104 go104 = '\x104' : go105 go105 = '\x105' : go106 go106 = '\x106' : go107 go107 = '\x107' : go108 go108 = '\x108' : go109 go109 = '\x109' : go110 go110 = '\x110' : go111 go111 = '\x111' : go112 go112 = '\x112' : go113 go113 = '\x113' : go114 go114 = '\x114' : go115 go115 = '\x115' : go116 go116 = '\x116' : go117 go117 = '\x117' : go118 go118 = '\x118' : go119 go119 = '\x119' : go120 go120 = '\x120' : go121 go121 = '\x121' : go122 go122 = '\x122' : go123 go123 = '\x123' : go124 go124 = '\x124' : go125 go125 = '\x125' : go126 go126 = '\x126' : go127 go127 = '\x127' : go128 go128 = '\x128' : go129 go129 = '\x129' : go130 go130 = '\x130' : go131 go131 = '\x131' : go132 go132 = '\x132' : go133 go133 = '\x133' : go134 go134 = '\x134' : go135 go135 = '\x135' : go136 go136 = '\x136' : go137 go137 = '\x137' : go138 go138 = '\x138' : go139 go139 = '\x139' : go140 go140 = '\x140' : go141 go141 = '\x141' : go142 go142 = '\x142' : go143 go143 = '\x143' : go144 go144 = '\x144' : go145 go145 = '\x145' : go146 go146 = '\x146' : go147 go147 = '\x147' : go148 go148 = '\x148' : go149 go149 = '\x149' : go150 go150 = '\x150' : go151 go151 = '\x151' : go152 go152 = '\x152' : go153 go153 = '\x153' : go154 go154 = '\x154' : go155 go155 = '\x155' : go156 go156 = '\x156' : go157 go157 = '\x157' : go158 go158 = '\x158' : go159 go159 = '\x159' : go160 go160 = '\x160' : go161 go161 = '\x161' : go162 go162 = '\x162' : go163 go163 = '\x163' : go164 go164 = '\x164' : go165 go165 = '\x165' : go166 go166 = '\x166' : go167 go167 = '\x167' : go168 go168 = '\x168' : go169 go169 = '\x169' : go170 go170 = '\x170' : go171 go171 = '\x171' : go172 go172 = '\x172' : go173 go173 = '\x173' : go174 go174 = '\x174' : go175 go175 = '\x175' : go176 go176 = '\x176' : go177 go177 = '\x177' : go178 go178 = '\x178' : go179 go179 = '\x179' : go180 go180 = '\x180' : go181 go181 = '\x181' : go182 go182 = '\x182' : go183 go183 = '\x183' : go184 go184 = '\x184' : go185 go185 = '\x185' : go186 go186 = '\x186' : go187 go187 = '\x187' : go188 go188 = '\x188' : go189 go189 = '\x189' : go190 go190 = '\x190' : go191 go191 = '\x191' : go192 go192 = '\x192' : go193 go193 = '\x193' : go194 go194 = '\x194' : go195 go195 = '\x195' : go196 go196 = '\x196' : go197 go197 = '\x197' : go198 go198 = '\x198' : go199 go199 = '\x199' : go200 go200 = '\x200' : go201 go201 = '\x201' : go202 go202 = '\x202' : go203 go203 = '\x203' : go204 go204 = '\x204' : go205 go205 = '\x205' : go206 go206 = '\x206' : go207 go207 = '\x207' : go208 go208 = '\x208' : go209 go209 = '\x209' : go210 go210 = '\x210' : go211 go211 = '\x211' : go212 go212 = '\x212' : go213 go213 = '\x213' : go214 go214 = '\x214' : go215 go215 = '\x215' : go216 go216 = '\x216' : go217 go217 = '\x217' : go218 go218 = '\x218' : go219 go219 = '\x219' : go220 go220 = '\x220' : go221 go221 = '\x221' : go222 go222 = '\x222' : go223 go223 = '\x223' : go224 go224 = '\x224' : go225 go225 = '\x225' : go226 go226 = '\x226' : go227 go227 = '\x227' : go228 go228 = '\x228' : go229 go229 = '\x229' : go230 go230 = '\x230' : go231 go231 = '\x231' : go232 go232 = '\x232' : go233 go233 = '\x233' : go234 go234 = '\x234' : go235 go235 = '\x235' : go236 go236 = '\x236' : go237 go237 = '\x237' : go238 go238 = '\x238' : go239 go239 = '\x239' : go240 go240 = '\x240' : go241 go241 = '\x241' : go242 go242 = '\x242' : go243 go243 = '\x243' : go244 go244 = '\x244' : go245 go245 = '\x245' : go246 go246 = '\x246' : go247 go247 = '\x247' : go248 go248 = '\x248' : go249 go249 = '\x249' : go250 go250 = '\x250' : go251 go251 = '\x251' : go252 go252 = '\x252' : go253 go253 = '\x253' : go254 go254 = '\x254' : go255 go255 = '\x255' : go256 go256 = '\x256' : go0 in go0 bigletrec' = let go0 = '\x0' : go1 go1 = '\x1' : go2 go2 = '\x2' : go3 go3 = '\x3' : go4 go4 = '\x4' : go5 go5 = '\x5' : go6 go6 = '\x6' : go7 go7 = '\x7' : go8 go8 = '\x8' : go9 go9 = '\x9' : go10 go10 = '\x10' : go11 go11 = '\x11' : go12 go12 = '\x12' : go13 go13 = '\x13' : go14 go14 = '\x14' : go15 go15 = '\x15' : go16 go16 = '\x16' : go17 go17 = '\x17' : go18 go18 = '\x18' : go19 go19 = '\x19' : go20 go20 = '\x20' : go21 go21 = '\x21' : go22 go22 = '\x22' : go23 go23 = '\x23' : go24 go24 = '\x24' : go25 go25 = '\x25' : go26 go26 = '\x26' : go27 go27 = '\x27' : go28 go28 = '\x28' : go29 go29 = '\x29' : go30 go30 = '\x30' : go31 go31 = '\x31' : go32 go32 = '\x32' : go33 go33 = '\x33' : go34 go34 = '\x34' : go35 go35 = '\x35' : go36 go36 = '\x36' : go37 go37 = '\x37' : go38 go38 = '\x38' : go39 go39 = '\x39' : go40 go40 = '\x40' : go41 go41 = '\x41' : go42 go42 = '\x42' : go43 go43 = '\x43' : go44 go44 = '\x44' : go45 go45 = '\x45' : go46 go46 = '\x46' : go47 go47 = '\x47' : go48 go48 = '\x48' : go49 go49 = '\x49' : go50 go50 = '\x50' : go51 go51 = '\x51' : go52 go52 = '\x52' : go53 go53 = '\x53' : go54 go54 = '\x54' : go55 go55 = '\x55' : go56 go56 = '\x56' : go57 go57 = '\x57' : go58 go58 = '\x58' : go59 go59 = '\x59' : go60 go60 = '\x60' : go61 go61 = '\x61' : go62 go62 = '\x62' : go63 go63 = '\x63' : go64 go64 = '\x64' : go65 go65 = '\x65' : go66 go66 = '\x66' : go67 go67 = '\x67' : go68 go68 = '\x68' : go69 go69 = '\x69' : go70 go70 = '\x70' : go71 go71 = '\x71' : go72 go72 = '\x72' : go73 go73 = '\x73' : go74 go74 = '\x74' : go75 go75 = '\x75' : go76 go76 = '\x76' : go77 go77 = '\x77' : go78 go78 = '\x78' : go79 go79 = '\x79' : go80 go80 = '\x80' : go81 go81 = '\x81' : go82 go82 = '\x82' : go83 go83 = '\x83' : go84 go84 = '\x84' : go85 go85 = '\x85' : go86 go86 = '\x86' : go87 go87 = '\x87' : go88 go88 = '\x88' : go89 go89 = '\x89' : go90 go90 = '\x90' : go91 go91 = '\x91' : go92 go92 = '\x92' : go93 go93 = '\x93' : go94 go94 = '\x94' : go95 go95 = '\x95' : go96 go96 = '\x96' : go97 go97 = '\x97' : go98 go98 = '\x98' : go99 go99 = '\x99' : go100 go100 = '\x100' : go101 go101 = '\x101' : go102 go102 = '\x102' : go103 go103 = '\x103' : go104 go104 = '\x104' : go105 go105 = '\x105' : go106 go106 = '\x106' : go107 go107 = '\x107' : go108 go108 = '\x108' : go109 go109 = '\x109' : go110 go110 = '\x110' : go111 go111 = '\x111' : go112 go112 = '\x112' : go113 go113 = '\x113' : go114 go114 = '\x114' : go115 go115 = '\x115' : go116 go116 = '\x116' : go117 go117 = '\x117' : go118 go118 = '\x118' : go119 go119 = '\x119' : go120 go120 = '\x120' : go121 go121 = '\x121' : go122 go122 = '\x122' : go123 go123 = '\x123' : go124 go124 = '\x124' : go125 go125 = '\x125' : go126 go126 = '\x126' : go127 go127 = '\x127' : go128 go128 = '\x128' : go129 go129 = '\x129' : go130 go130 = '\x130' : go131 go131 = '\x131' : go132 go132 = '\x132' : go133 go133 = '\x133' : go134 go134 = '\x134' : go135 go135 = '\x135' : go136 go136 = '\x136' : go137 go137 = '\x137' : go138 go138 = '\x138' : go139 go139 = '\x139' : go140 go140 = '\x140' : go141 go141 = '\x141' : go142 go142 = '\x142' : go143 go143 = '\x143' : go144 go144 = '\x144' : go145 go145 = '\x145' : go146 go146 = '\x146' : go147 go147 = '\x147' : go148 go148 = '\x148' : go149 go149 = '\x149' : go150 go150 = '\x150' : go151 go151 = '\x151' : go152 go152 = '\x152' : go153 go153 = '\x153' : go154 go154 = '\x154' : go155 go155 = '\x155' : go156 go156 = '\x156' : go157 go157 = '\x157' : go158 go158 = '\x158' : go159 go159 = '\x159' : go160 go160 = '\x160' : go161 go161 = '\x161' : go162 go162 = '\x162' : go163 go163 = '\x163' : go164 go164 = '\x164' : go165 go165 = '\x165' : go166 go166 = '\x166' : go167 go167 = '\x167' : go168 go168 = '\x168' : go169 go169 = '\x169' : go170 go170 = '\x170' : go171 go171 = '\x171' : go172 go172 = '\x172' : go173 go173 = '\x173' : go174 go174 = '\x174' : go175 go175 = '\x175' : go176 go176 = '\x176' : go177 go177 = '\x177' : go178 go178 = '\x178' : go179 go179 = '\x179' : go180 go180 = '\x180' : go181 go181 = '\x181' : go182 go182 = '\x182' : go183 go183 = '\x183' : go184 go184 = '\x184' : go185 go185 = '\x185' : go186 go186 = '\x186' : go187 go187 = '\x187' : go188 go188 = '\x188' : go189 go189 = '\x189' : go190 go190 = '\x190' : go191 go191 = '\x191' : go192 go192 = '\x192' : go193 go193 = '\x193' : go194 go194 = '\x194' : go195 go195 = '\x195' : go196 go196 = '\x196' : go197 go197 = '\x197' : go198 go198 = '\x198' : go199 go199 = '\x199' : go200 go200 = '\x200' : go201 go201 = '\x201' : go202 go202 = '\x202' : go203 go203 = '\x203' : go204 go204 = '\x204' : go205 go205 = '\x205' : go206 go206 = '\x206' : go207 go207 = '\x207' : go208 go208 = '\x208' : go209 go209 = '\x209' : go210 go210 = '\x210' : go211 go211 = '\x211' : go212 go212 = '\x212' : go213 go213 = '\x213' : go214 go214 = '\x214' : go215 go215 = '\x215' : go216 go216 = '\x216' : go217 go217 = '\x217' : go218 go218 = '\x218' : go219 go219 = '\x219' : go220 go220 = '\x220' : go221 go221 = '\x221' : go222 go222 = '\x222' : go223 go223 = '\x223' : go224 go224 = '\x224' : go225 go225 = '\x225' : go226 go226 = '\x226' : go227 go227 = '\x227' : go228 go228 = '\x228' : go229 go229 = '\x229' : go230 go230 = '\x230' : go231 go231 = '\x231' : go232 go232 = '\x232' : go233 go233 = '\x233' : go234 go234 = '\x234' : go235 go235 = '\x235' : go236 go236 = '\x236' : go237 go237 = '\x237' : go238 go238 = '\x238' : go239 go239 = '\x239' : go240 go240 = '\x240' : go241 go241 = '\x241' : go242 go242 = '\x242' : go243 go243 = '\x243' : go244 go244 = '\x244' : go245 go245 = '\x245' : go246 go246 = '\x246' : go247 go247 = '\x247' : go248 go248 = '\x248' : go249 go249 = '\x249' : go250 go250 = '\x250' : go251 go251 = '\x251' : go252 go252 = '\x252' : go253 go253 = '\x253' : go254 go254 = '\x254' : go255 go255 = '\x255' : go256 go256 = '\x256' : go0 in go0 badletrec' = let go0 = 'a' : go1 go1 = '\x1' : go2 go2 = '\x2' : go3 go3 = '\x3' : go4 go4 = '\x4' : go5 go5 = '\x5' : go6 go6 = '\x6' : go7 go7 = '\x7' : go8 go8 = '\x8' : go9 go9 = '\x9' : go10 go10 = '\x10' : go11 go11 = '\x11' : go12 go12 = '\x12' : go13 go13 = '\x13' : go14 go14 = '\x14' : go15 go15 = '\x15' : go16 go16 = '\x16' : go17 go17 = '\x17' : go18 go18 = '\x18' : go19 go19 = '\x19' : go20 go20 = '\x20' : go21 go21 = '\x21' : go22 go22 = '\x22' : go23 go23 = '\x23' : go24 go24 = '\x24' : go25 go25 = '\x25' : go26 go26 = '\x26' : go27 go27 = '\x27' : go28 go28 = '\x28' : go29 go29 = '\x29' : go30 go30 = '\x30' : go31 go31 = '\x31' : go32 go32 = '\x32' : go33 go33 = '\x33' : go34 go34 = '\x34' : go35 go35 = '\x35' : go36 go36 = '\x36' : go37 go37 = '\x37' : go38 go38 = '\x38' : go39 go39 = '\x39' : go40 go40 = '\x40' : go41 go41 = '\x41' : go42 go42 = '\x42' : go43 go43 = '\x43' : go44 go44 = '\x44' : go45 go45 = '\x45' : go46 go46 = '\x46' : go47 go47 = '\x47' : go48 go48 = '\x48' : go49 go49 = '\x49' : go50 go50 = '\x50' : go51 go51 = '\x51' : go52 go52 = '\x52' : go53 go53 = '\x53' : go54 go54 = '\x54' : go55 go55 = '\x55' : go56 go56 = '\x56' : go57 go57 = '\x57' : go58 go58 = '\x58' : go59 go59 = '\x59' : go60 go60 = '\x60' : go61 go61 = '\x61' : go62 go62 = '\x62' : go63 go63 = '\x63' : go64 go64 = '\x64' : go65 go65 = '\x65' : go66 go66 = '\x66' : go67 go67 = '\x67' : go68 go68 = '\x68' : go69 go69 = '\x69' : go70 go70 = '\x70' : go71 go71 = '\x71' : go72 go72 = '\x72' : go73 go73 = '\x73' : go74 go74 = '\x74' : go75 go75 = '\x75' : go76 go76 = '\x76' : go77 go77 = '\x77' : go78 go78 = '\x78' : go79 go79 = '\x79' : go80 go80 = '\x80' : go81 go81 = '\x81' : go82 go82 = '\x82' : go83 go83 = '\x83' : go84 go84 = '\x84' : go85 go85 = '\x85' : go86 go86 = '\x86' : go87 go87 = '\x87' : go88 go88 = '\x88' : go89 go89 = '\x89' : go90 go90 = '\x90' : go91 go91 = '\x91' : go92 go92 = '\x92' : go93 go93 = '\x93' : go94 go94 = '\x94' : go95 go95 = '\x95' : go96 go96 = '\x96' : go97 go97 = '\x97' : go98 go98 = '\x98' : go99 go99 = '\x99' : go100 go100 = '\x100' : go101 go101 = '\x101' : go102 go102 = '\x102' : go103 go103 = '\x103' : go104 go104 = '\x104' : go105 go105 = '\x105' : go106 go106 = '\x106' : go107 go107 = '\x107' : go108 go108 = '\x108' : go109 go109 = '\x109' : go110 go110 = '\x110' : go111 go111 = '\x111' : go112 go112 = '\x112' : go113 go113 = '\x113' : go114 go114 = '\x114' : go115 go115 = '\x115' : go116 go116 = '\x116' : go117 go117 = '\x117' : go118 go118 = '\x118' : go119 go119 = '\x119' : go120 go120 = '\x120' : go121 go121 = '\x121' : go122 go122 = '\x122' : go123 go123 = '\x123' : go124 go124 = '\x124' : go125 go125 = '\x125' : go126 go126 = '\x126' : go127 go127 = '\x127' : go128 go128 = '\x128' : go129 go129 = '\x129' : go130 go130 = '\x130' : go131 go131 = '\x131' : go132 go132 = '\x132' : go133 go133 = '\x133' : go134 go134 = '\x134' : go135 go135 = '\x135' : go136 go136 = '\x136' : go137 go137 = '\x137' : go138 go138 = '\x138' : go139 go139 = '\x139' : go140 go140 = '\x140' : go141 go141 = '\x141' : go142 go142 = '\x142' : go143 go143 = '\x143' : go144 go144 = '\x144' : go145 go145 = '\x145' : go146 go146 = '\x146' : go147 go147 = '\x147' : go148 go148 = '\x148' : go149 go149 = '\x149' : go150 go150 = '\x150' : go151 go151 = '\x151' : go152 go152 = '\x152' : go153 go153 = '\x153' : go154 go154 = '\x154' : go155 go155 = '\x155' : go156 go156 = '\x156' : go157 go157 = '\x157' : go158 go158 = '\x158' : go159 go159 = '\x159' : go160 go160 = '\x160' : go161 go161 = '\x161' : go162 go162 = '\x162' : go163 go163 = '\x163' : go164 go164 = '\x164' : go165 go165 = '\x165' : go166 go166 = '\x166' : go167 go167 = '\x167' : go168 go168 = '\x168' : go169 go169 = '\x169' : go170 go170 = '\x170' : go171 go171 = '\x171' : go172 go172 = '\x172' : go173 go173 = '\x173' : go174 go174 = '\x174' : go175 go175 = '\x175' : go176 go176 = '\x176' : go177 go177 = '\x177' : go178 go178 = '\x178' : go179 go179 = '\x179' : go180 go180 = '\x180' : go181 go181 = '\x181' : go182 go182 = '\x182' : go183 go183 = '\x183' : go184 go184 = '\x184' : go185 go185 = '\x185' : go186 go186 = '\x186' : go187 go187 = '\x187' : go188 go188 = '\x188' : go189 go189 = '\x189' : go190 go190 = '\x190' : go191 go191 = '\x191' : go192 go192 = '\x192' : go193 go193 = '\x193' : go194 go194 = '\x194' : go195 go195 = '\x195' : go196 go196 = '\x196' : go197 go197 = '\x197' : go198 go198 = '\x198' : go199 go199 = '\x199' : go200 go200 = '\x200' : go201 go201 = '\x201' : go202 go202 = '\x202' : go203 go203 = '\x203' : go204 go204 = '\x204' : go205 go205 = '\x205' : go206 go206 = '\x206' : go207 go207 = '\x207' : go208 go208 = '\x208' : go209 go209 = '\x209' : go210 go210 = '\x210' : go211 go211 = '\x211' : go212 go212 = '\x212' : go213 go213 = '\x213' : go214 go214 = '\x214' : go215 go215 = '\x215' : go216 go216 = '\x216' : go217 go217 = '\x217' : go218 go218 = '\x218' : go219 go219 = '\x219' : go220 go220 = '\x220' : go221 go221 = '\x221' : go222 go222 = '\x222' : go223 go223 = '\x223' : go224 go224 = '\x224' : go225 go225 = '\x225' : go226 go226 = '\x226' : go227 go227 = '\x227' : go228 go228 = '\x228' : go229 go229 = '\x229' : go230 go230 = '\x230' : go231 go231 = '\x231' : go232 go232 = '\x232' : go233 go233 = '\x233' : go234 go234 = '\x234' : go235 go235 = '\x235' : go236 go236 = '\x236' : go237 go237 = '\x237' : go238 go238 = '\x238' : go239 go239 = '\x239' : go240 go240 = '\x240' : go241 go241 = '\x241' : go242 go242 = '\x242' : go243 go243 = '\x243' : go244 go244 = '\x244' : go245 go245 = '\x245' : go246 go246 = '\x246' : go247 go247 = '\x247' : go248 go248 = '\x248' : go249 go249 = '\x249' : go250 go250 = '\x250' : go251 go251 = '\x251' : go252 go252 = '\x252' : go253 go253 = '\x253' : go254 go254 = '\x254' : go255 go255 = '\x255' : go256 go256 = '\x256' : go0 in go0 inspect $ 'bigletrec === 'bigletrec' inspect $ 'bigletrec =/= 'badletrec' main :: IO () main = pure () inspection-testing-0.4.2.1/examples/Regression.hs0000644000000000000000000000047613476412656020207 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- This is a kitchen sink test file for various regressions -- reported via GitHub import Test.Inspection -- https://github.com/nomeata/inspection-testing/issues/35 empty1, empty2 :: [a] empty1 = map id [] empty2 = [] inspect $ 'empty1 === 'empty2 main :: IO () main = return () inspection-testing-0.4.2.1/examples/DoesNotUse.hs0000644000000000000000000000071613476412656020114 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module DoesNotUse where import Test.Inspection import Control.Exception.Base (patError) matches (Just _) = True matches Nothing = False partial (Just _) = Left inspect $ ('matches `doesNotUse` 'Just) { expectFail = True } inspect $ 'matches `doesNotUse` 'patError inspect $ ('partial `doesNotUse` 'patError) { expectFail = True } inspect $ ('partial `doesNotUse` 'Left) { expectFail = True } main :: IO () main = return () inspection-testing-0.4.2.1/examples/Text.hs0000644000000000000000000000141313476412656017003 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Text (main) where import Test.Inspection import Data.Text as T import Data.Text.Encoding as E import Data.ByteString (ByteString) -- Some cases of successful fusion: toUpperString :: String -> String toUpperString = T.unpack . T.toUpper . T.pack toUpperBytestring :: ByteString -> String toUpperBytestring = T.unpack . T.toUpper . E.decodeUtf8 -- This is the example from the text documentation. -- Unfortunately it fails, the problem seems to be T.length. countChars :: ByteString -> Int countChars = T.length . T.toUpper . E.decodeUtf8 inspect $ 'toUpperString `hasNoType` ''T.Text inspect $ 'toUpperBytestring `hasNoType` ''T.Text inspect $ ('countChars `hasNoType` ''T.Text) { expectFail = True } main :: IO () main = return () inspection-testing-0.4.2.1/examples/Fusion.hs0000644000000000000000000000126313476412656017325 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Fusion (main) where import Test.Inspection import Data.List (foldl', sort) sumUp1 :: Int -> Bool sumUp1 n = sum [1..n] > 1000 sumUp2 :: Int -> Bool sumUp2 n | 1 > n = False sumUp2 n = go 1 0 > 1000 where go m s | m == n = (s + m) | otherwise = go (m+1) (s+m) -- Example for a non-fusing funtion sumUpSort :: Int -> Int sumUpSort n = sum . sort $ [1..n] inspect $ 'sumUp1 === 'sumUp2 inspect $ 'sumUp1 `hasNoType` ''[] inspect $ ('sumUp1 `hasNoType` ''Int) { expectFail = True } inspect $ mkObligation 'sumUp1 NoAllocation inspect $ ('sumUpSort `hasNoType` ''[]) { expectFail = True } main :: IO () main = return () inspection-testing-0.4.2.1/examples/GenericLens.hs0000644000000000000000000000244713476412656020265 0ustar0000000000000000{-# LANGUAGE RankNTypes, DeriveGeneric, TypeApplications, DataKinds, ExistentialQuantification, TemplateHaskell #-} module GenericLens (main) where import GHC.Generics import Data.Generics.Product import Test.Inspection data Record = MkRecord { fieldA :: Int , fieldB :: Bool } deriving Generic type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s fieldALensManual :: Lens' Record Int fieldALensManual f (MkRecord a b) = (\a -> MkRecord a b) <$> f a -- Coyoneda optimization data Coyoneda f b = forall a. Coyoneda (a -> b) (f a) instance Functor (Coyoneda f) where fmap f (Coyoneda g fa) = Coyoneda (f . g) fa inj :: Functor f => Coyoneda f a -> f a inj (Coyoneda f a) = fmap f a proj :: Functor f => f a -> Coyoneda f a proj fa = Coyoneda id fa ravel :: Functor f => ((a -> Coyoneda f b) -> (s -> Coyoneda f t)) -> (a -> f b) -> (s -> f t) ravel coy f s = inj $ coy (\a -> proj (f a)) s -- the examples fieldALensGeneric :: Lens' Record Int fieldALensGeneric = field @"fieldA" fieldALensGenericYoneda :: Lens' Record Int fieldALensGenericYoneda = ravel (field @"fieldA") main :: IO () main = return () -- the check inspect $ 'fieldALensManual === 'fieldALensGeneric inspect $ 'fieldALensManual === 'fieldALensGenericYoneda inspection-testing-0.4.2.1/examples/Generics.hs0000644000000000000000000000077613476412656017631 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, TemplateHaskell #-} module Generics (main) where import GHC.Generics import Test.Inspection data Record = MkRecord { fieldA :: Int , fieldB :: Bool } deriving Generic myRecord :: Record myRecord = MkRecord 1 True genericRep :: Rep Record x genericRep = from myRecord roundTripRep :: Record roundTripRep = to $ from myRecord main :: IO () main = return () -- the check inspect $ hasNoGenerics 'roundTripRep inspect $ (hasNoGenerics 'genericRep) { expectFail = True } inspection-testing-0.4.2.1/examples/Dictionary.hs0000644000000000000000000000170113476412656020164 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Dictionary (main) where import Test.Inspection import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad (replicateM_) import Data.Traversable (foldMapDefault) import Data.Semigroup (Semigroup) putStrLn' :: MonadIO m => String -> m () putStrLn' = liftIO . putStrLn action :: MonadIO m => m () action = putStrLn' "foo" >> putStrLn' "bar" specialized :: IO () specialized = action inspect $ hasNoTypeClasses 'specialized inspect $ (hasNoTypeClasses 'action) { expectFail = True } inspect $ hasNoTypeClassesExcept 'action [''MonadIO, ''Monad, ''Applicative, ''Functor] listFoldMap :: Monoid m => (a -> m) -> [a] -> m listFoldMap = foldMapDefault #if __GLASGOW_HASKELL__ >= 802 inspect $ hasNoTypeClassesExcept 'listFoldMap [''Monoid, ''Semigroup] #else inspect $ (hasNoTypeClassesExcept 'listFoldMap [''Monoid, ''Semigroup]) { expectFail = True } #endif main :: IO () main = return () inspection-testing-0.4.2.1/examples/NS_NP.hs0000644000000000000000000000173013476412656016776 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, DataKinds, PolyKinds, TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O -fplugin-opt=Test.Inspection.Plugin:quiet #-} module NS_NP (main) where import Test.Inspection data NS (f :: k -> *) (xs :: [k]) where Z :: f x -> NS f (x : xs) S :: !(NS f xs) -> NS f (x : xs) data NP (f :: k -> *) (xs :: [k]) where Nil :: NP f '[] (:*) :: f x -> !(NP f xs) -> NP f (x : xs) newtype I a = I a from :: Ordering -> NS (NP I) '[ '[], '[], '[] ] from = \ x -> case x of LT -> Z Nil EQ -> S (Z Nil) GT -> S (S (Z Nil)) {-# INLINE from #-} to :: NS (NP I) '[ '[], '[], '[] ] -> Ordering to = \ x -> case x of (Z Nil) -> LT (S (Z Nil)) -> EQ (S (S (Z Nil))) -> GT _ -> error "unreachable" {-# INLINE to #-} roundtrip :: Ordering -> Ordering roundtrip = to . from {-# INLINE roundtrip #-} roundtrip_id :: Ordering -> Ordering roundtrip_id x = x main :: IO () main = return () inspect $ 'roundtrip === 'roundtrip_id inspection-testing-0.4.2.1/examples/Simple.hs0000644000000000000000000000042413476412656017311 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Simple (main) where import Test.Inspection import Data.Maybe lhs, rhs :: (a -> b) -> Maybe a -> Bool lhs f x = isNothing (fmap f x) rhs f Nothing = True rhs f (Just _) = False inspect $ 'lhs === 'rhs main :: IO () main = return () inspection-testing-0.4.2.1/examples/SimpleTest.hs0000644000000000000000000000134413476412656020153 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main (main) where import Test.Inspection import Data.Maybe import System.Exit lhs, rhs, something_else :: (a -> b) -> Maybe a -> Bool lhs f x = isNothing (fmap f x) rhs _ Nothing = True rhs _ (Just _) = False something_else _ _ = False printResult :: Result -> IO () printResult (Success s) = putStrLn s printResult (Failure s) = putStrLn s isSuccess :: Result -> Bool isSuccess (Success _) = True isSuccess (Failure _) = False results :: [Result] results = [ $(inspectTest $ 'lhs === 'rhs) , $(inspectTest $ 'lhs === 'something_else) ] main :: IO () main = do mapM_ printResult results if map isSuccess results == [True, False] then exitSuccess else exitFailure inspection-testing-0.4.2.1/src/0000755000000000000000000000000013476412656014475 5ustar0000000000000000inspection-testing-0.4.2.1/src/Test/0000755000000000000000000000000013476412656015414 5ustar0000000000000000inspection-testing-0.4.2.1/src/Test/Inspection.hs0000644000000000000000000002235013476412656020065 0ustar0000000000000000-- | -- Description : Inspection Testing for Haskell -- Copyright : (c) Joachim Breitner, 2017 -- License : MIT -- Maintainer : mail@joachim-breitner.de -- Portability : GHC specifc -- -- This module supports the accompanying GHC plugin "Test.Inspection.Plugin" and adds -- to GHC the ability to do inspection testing. {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} module Test.Inspection ( -- * Synopsis -- $synposis -- * Registering obligations inspect, inspectTest, Result(..), -- * Defining obligations Obligation(..), mkObligation, Property(..), -- * Convenience functions -- $convenience (===), (==-), (=/=), hasNoType, hasNoGenerics, hasNoTypeClasses, hasNoTypeClassesExcept, doesNotUse, coreOf, ) where import Language.Haskell.TH import Language.Haskell.TH.Syntax (Quasi(qNewName), liftData, addTopDecls) #if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0) import Language.Haskell.TH.Syntax (addCorePlugin) #endif import Data.Data import Data.Maybe import GHC.Exts (lazy) import GHC.Generics (V1(), U1(), M1(), K1(), (:+:), (:*:), (:.:), Rec1, Par1) {- $synposis To use inspection testing, you need to 1. enable the @TemplateHaskell@ language extension 2. declare your proof obligations using 'inspect' or 'inspectTest' An example module is @ {-\# LANGUAGE TemplateHaskell \#-} module Simple where import Test.Inspection import Data.Maybe lhs, rhs :: (a -> b) -> Maybe a -> Bool lhs f x = isNothing (fmap f x) rhs f Nothing = True rhs f (Just _) = False inspect $ 'lhs === 'rhs @ On GHC < 8.4, you have to explicitly load the plugin: @ {-\# LANGUAGE TemplateHaskell \#-} @ -} -- Description of test obligations -- | This data type describes an inspection testing obligation. -- -- It is recommended to build it using 'mkObligation', for backwards -- compatibility when new fields are added. You can also use the more -- mnemonic convenience functions like '(===)' or 'hasNoType'. -- -- The obligation needs to be passed to 'inspect'. data Obligation = Obligation { target :: Name -- ^ The target of a test obligation; invariably the name of a local -- definition. To get the name of a function @foo@, write @'foo@. This requires -- @{-\# LANGUAGE TemplateHaskell \#-}@. , property :: Property -- ^ The property of the target to be checked. , testName :: Maybe String -- ^ An optional name for the test , expectFail :: Bool -- ^ Do we expect this property to fail? -- (Only used by 'inspect', not by 'inspectTest') , srcLoc :: Maybe Loc -- ^ The source location where this obligation is defined. -- This is filled in by 'inspect'. , storeResult :: Maybe String -- ^ If this is 'Nothing', then report errors during compilation. -- Otherwise, update the top-level definition with this name. } deriving Data -- | Properties of the obligation target to be checked. data Property -- | Are the two functions equal? -- -- More precisely: @f@ is equal to @g@ if either the definition of @f@ is -- @f = g@, or the definition of @g@ is @g = f@, or if the definitions are -- @f = e@ and @g = e@. -- -- In general @f@ and @g@ need to be defined in this module, so that their -- actual defintions can be inspected. -- -- If the boolean flag is true, then ignore types during the comparison. = EqualTo Name Bool -- | Do none of these types appear anywhere in the definition of the function -- (neither locally bound nor passed as arguments) | NoTypes [Name] -- | Does this function perform no heap allocations. | NoAllocation -- | Does this value contain dictionaries (/except/ of the listed classes). | NoTypeClasses [Name] -- | Does not contain this value (in terms or patterns) | NoUseOf [Name] -- | Always satisfied, but dumps the value in non-quiet mode. | CoreOf deriving Data -- | Creates an inspection obligation for the given function name -- with default values for the optional fields. mkObligation :: Name -> Property -> Obligation mkObligation target prop = Obligation { target = target , property = prop , testName = Nothing , srcLoc = Nothing , expectFail = False , storeResult = Nothing } {- $convenience These convenience functions create common test obligations directly. -} -- | Declare two functions to be equal (see 'EqualTo') (===) :: Name -> Name -> Obligation (===) = mkEquality False False infix 9 === -- | Declare two functions to be equal, but ignoring -- type lambdas, type arguments and type casts (see 'EqualTo') (==-) :: Name -> Name -> Obligation (==-) = mkEquality False True infix 9 ==- -- | Declare two functions to be equal, but expect the test to fail (see 'EqualTo' and 'expectFail') -- (This is useful for documentation purposes, or as a TODO list.) (=/=) :: Name -> Name -> Obligation (=/=) = mkEquality True False infix 9 =/= mkEquality :: Bool -> Bool -> Name -> Name -> Obligation mkEquality expectFail ignore_types n1 n2 = (mkObligation n1 (EqualTo n2 ignore_types)) { expectFail = expectFail } -- | Declare that in a function’s implementation, the given type does not occur. -- -- More precisely: No locally bound variable (let-bound, lambda-bound or -- pattern-bound) has a type that contains the given type constructor. -- -- @'inspect' $ fusedFunction ``hasNoType`` ''[]@ hasNoType :: Name -> Name -> Obligation hasNoType n tn = mkObligation n (NoTypes [tn]) -- | Declare that a function’s implementation does not contain any generic types. -- This is just 'asNoType' applied to the usual type constructors used in -- "GHC.Generics". -- -- @inspect $ hasNoGenerics genericFunction@ hasNoGenerics :: Name -> Obligation hasNoGenerics n = mkObligation n (NoTypes [ ''V1, ''U1, ''M1, ''K1, ''(:+:), ''(:*:), ''(:.:), ''Rec1 , ''Par1 ]) -- | Declare that a function's implementation does not include dictionaries. -- -- More precisely: No locally bound variable (let-bound, lambda-bound or -- pattern-bound) has a type that contains a type that mentions a type class. -- -- @'inspect' $ 'hasNoTypeClasses' specializedFunction@ hasNoTypeClasses :: Name -> Obligation hasNoTypeClasses n = hasNoTypeClassesExcept n [] -- | A variant of 'hasNoTypeClasses', which white-lists some type-classes. -- -- @'inspect' $ fieldLens ``hasNoTypeClassesExcept`` [''Functor]@ hasNoTypeClassesExcept :: Name -> [Name] -> Obligation hasNoTypeClassesExcept n tns = mkObligation n (NoTypeClasses tns) -- | Declare that a function's implementation does not use the given -- variable (either in terms or -- if it is a constructor -- in patterns). -- -- @'inspect' $ foo ``doesNotUse`` 'error@ doesNotUse :: Name -> Name -> Obligation doesNotUse n ns = mkObligation n (NoUseOf [ns]) -- | Dump the Core of the value. -- -- @'inspect' $ 'coreOf' 'foo@ -- -- This is useful when you need to inspect some values manually. -- coreOf :: Name -> Obligation coreOf n = mkObligation n CoreOf -- The exported TH functions inspectCommon :: AnnTarget -> Obligation -> Q [Dec] inspectCommon annTarget obl = do #if MIN_VERSION_GLASGOW_HASKELL(8,4,0,0) addCorePlugin "Test.Inspection.Plugin" #endif loc <- location annExpr <- liftData (obl { srcLoc = Just $ fromMaybe loc $ srcLoc obl }) pure [PragmaD (AnnP annTarget annExpr)] -- | As seen in the example above, the entry point to inspection testing is the -- 'inspect' function, to which you pass an 'Obligation'. -- It will report test failures at compile time. inspect :: Obligation -> Q [Dec] inspect = inspectCommon ModuleAnnotation -- | The result of 'inspectTest', which has a more or less helpful text message data Result = Failure String | Success String deriving Show didNotRunPluginError :: Result didNotRunPluginError = lazy (error "Test.Inspection.Plugin did not run") {-# NOINLINE didNotRunPluginError #-} -- | This is a variant that allows compilation to succeed in any case, -- and instead indicates the result as a value of type 'Result', -- which allows seamless integration into test frameworks. -- -- This variant ignores the 'expectFail' field of the obligation. Instead, -- it is expected that you use the corresponding functionality in your test -- framework (e.g. tasty-expected-failure) inspectTest :: Obligation -> Q Exp inspectTest obl = do nameS <- genName name <- newUniqueName nameS anns <- inspectCommon (ValueAnnotation name) obl addTopDecls $ [ SigD name (ConT ''Result) , ValD (VarP name) (NormalB (VarE 'didNotRunPluginError)) [] , PragmaD (InlineP name NoInline FunLike AllPhases) ] ++ anns return $ VarE name where genName = do (r,c) <- loc_start <$> location return $ "inspect_" ++ show r ++ "_" ++ show c -- | Like newName, but even more unique (unique across different splices), -- and with unique @nameBase@s. Precondition: the string is a valid Haskell -- alphanumeric identifier (could be upper- or lower-case). newUniqueName :: Quasi q => String -> q Name newUniqueName str = do n <- qNewName str qNewName $ show n -- This is from https://ghc.haskell.org/trac/ghc/ticket/13054#comment:1 inspection-testing-0.4.2.1/src/Test/Inspection/0000755000000000000000000000000013476412656017527 5ustar0000000000000000inspection-testing-0.4.2.1/src/Test/Inspection/Plugin.hs0000644000000000000000000003313413476412656021325 0ustar0000000000000000-- | See "Test.Inspection". -- {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} module Test.Inspection.Plugin (plugin) where import Control.Monad import System.Exit import Data.Either import Data.Maybe import Data.Bifunctor import Data.List import qualified Data.Map.Strict as M import qualified Language.Haskell.TH.Syntax as TH import GhcPlugins hiding (SrcLoc) import Outputable import Test.Inspection (Obligation(..), Property(..), Result(..)) import Test.Inspection.Core -- | The plugin. It supports some options: -- -- * @-fplugin-opt=Test.Inspection.Plugin:keep-going@ to ignore a failing build -- * @-fplugin-opt=Test.Inspection.Plugin:keep-going-O0@ to ignore a failing build when optimisations are off -- * @-fplugin-opt=Test.Inspection.Plugin:quiet@ to be silent if all obligations are fulfilled plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install #if __GLASGOW_HASKELL__ >= 806 , pluginRecompile = \_args -> pure NoForceRecompile #endif } data UponFailure = AbortCompilation | KeepGoingO0 | KeepGoing deriving Eq data ReportingMode = Verbose | Quiet deriving Eq data ResultTarget = PrintAndAbort | StoreAt Name install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install args passes = return $ passes ++ [pass] where pass = CoreDoPluginPass "Test.Inspection.Plugin" (proofPass upon_failure report) upon_failure | "keep-going" `elem` args = KeepGoing | "keep-going-O0" `elem` args = KeepGoingO0 | otherwise = AbortCompilation report | "quiet" `elem` args = Quiet | otherwise = Verbose extractObligations :: ModGuts -> (ModGuts, [(ResultTarget, Obligation)]) extractObligations guts = (guts', obligations) where (anns_clean, obligations) = partitionMaybe findObligationAnn (mg_anns guts) guts' = guts { mg_anns = anns_clean } findObligationAnn :: Annotation -> Maybe (ResultTarget, Obligation) findObligationAnn (Annotation (ModuleTarget _) payload) | Just obl <- fromSerialized deserializeWithData payload = Just (PrintAndAbort, obl) findObligationAnn (Annotation (NamedTarget n) payload) | Just obl <- fromSerialized deserializeWithData payload = Just (StoreAt n, obl) findObligationAnn _ = Nothing prettyObligation :: Module -> Obligation -> String -> String prettyObligation mod (Obligation {..}) result = maybe "" myPrettySrcLoc srcLoc ++ ": " ++ name ++ " " ++ result where name = case testName of Just n -> n Nothing -> prettyProperty mod target property prettyProperty :: Module -> TH.Name -> Property -> String prettyProperty mod target (EqualTo n2 False) = showTHName mod target ++ " === " ++ showTHName mod n2 prettyProperty mod target (EqualTo n2 True) = showTHName mod target ++ " ==- " ++ showTHName mod n2 prettyProperty mod target (NoTypes [t]) = showTHName mod target ++ " `hasNoType` " ++ showTHName mod t prettyProperty mod target (NoTypes ts) = showTHName mod target ++ " mentions none of " ++ intercalate ", " (map (showTHName mod) ts) prettyProperty mod target NoAllocation = showTHName mod target ++ " does not allocate" prettyProperty mod target (NoTypeClasses []) = showTHName mod target ++ " does not contain dictionary values" prettyProperty mod target (NoTypeClasses ts) = showTHName mod target ++ " does not contain dictionary values except of " ++ intercalate ", " (map (showTHName mod) ts) prettyProperty mod target (NoUseOf ns) = showTHName mod target ++ " uses none of " ++ intercalate ", " (map (showTHName mod) ns) prettyProperty mod target CoreOf = showTHName mod target ++ " core dump" -- :) -- | Like show, but omit the module name if it is he current module showTHName :: Module -> TH.Name -> String showTHName mod (TH.Name occ (TH.NameQ m)) | moduleNameString (moduleName mod) == TH.modString m = TH.occString occ showTHName mod (TH.Name occ (TH.NameG _ _ m)) | moduleNameString (moduleName mod) == TH.modString m = TH.occString occ showTHName _ n = show n data Stat = ExpSuccess | ExpFailure | UnexpSuccess | UnexpFailure | StoredResult deriving (Enum, Eq, Ord, Bounded) type Stats = M.Map Stat Int type Updates = [(Name, Result)] tick :: Stat -> Stats tick s = M.singleton s 1 checkObligation :: ReportingMode -> ModGuts -> (ResultTarget, Obligation) -> CoreM (Updates, Stats) checkObligation report guts (reportTarget, obl) = do res <- checkProperty guts (target obl) (property obl) case reportTarget of PrintAndAbort -> do category <- case (res, expectFail obl) of -- Property holds (ResSuccess, False) -> do unless (report == Quiet) $ putMsgS $ prettyObligation (mg_module guts) obl expSuccess return ExpSuccess (ResSuccess, True) -> do putMsgS $ prettyObligation (mg_module guts) obl unexpSuccess return UnexpSuccess -- Property holds, with extra message (ResSuccessWithMessage reportDoc, False) -> do unless (report == Quiet) $ do putMsgS $ prettyObligation (mg_module guts) obl expSuccess putMsg reportDoc return ExpSuccess (ResSuccessWithMessage reportDoc, True) -> do putMsgS $ prettyObligation (mg_module guts) obl unexpSuccess putMsg reportDoc return UnexpSuccess -- Property does not hold (ResFailure reportDoc, False) -> do putMsgS $ prettyObligation (mg_module guts) obl unexpFailure putMsg $ reportDoc return UnexpFailure (ResFailure _, True) -> do unless (report == Quiet) $ putMsgS $ prettyObligation (mg_module guts) obl expFailure return ExpFailure return ([], tick category) StoreAt name -> do dflags <- getDynFlags let result = case res of ResSuccess -> Success $ showSDoc dflags $ text (prettyObligation (mg_module guts) obl expSuccess) ResSuccessWithMessage msg -> Success $ showSDoc dflags $ text (prettyObligation (mg_module guts) obl expSuccess) $$ msg ResFailure reportMsg -> Failure $ showSDoc dflags $ text (prettyObligation (mg_module guts) obl unexpFailure) $$ reportMsg pure ([(name, result)], tick StoredResult) where expSuccess = "passed." unexpSuccess = "passed unexpectedly!" unexpFailure = "failed:" expFailure = "failed expectedly." data CheckResult = ResSuccess | ResSuccessWithMessage SDoc | ResFailure SDoc lookupNameInGuts :: ModGuts -> Name -> Maybe (Var, CoreExpr) lookupNameInGuts guts n = listToMaybe [ (v,e) | (v,e) <- flattenBinds (mg_binds guts) , getName v == n ] updateNameInGuts :: Name -> CoreExpr -> ModGuts -> ModGuts updateNameInGuts n expr guts = guts {mg_binds = map (updateNameInGut n expr) (mg_binds guts) } updateNameInGut :: Name -> CoreExpr -> CoreBind -> CoreBind updateNameInGut n e (NonRec v _) | getName v == n = NonRec v e updateNameInGut _ _ bind = bind checkProperty :: ModGuts -> TH.Name -> Property -> CoreM CheckResult checkProperty guts thn1 (EqualTo thn2 ignore_types) = do n1 <- fromTHName thn1 n2 <- fromTHName thn2 let p1 = lookupNameInGuts guts n1 let p2 = lookupNameInGuts guts n2 if | n1 == n2 -> pure ResSuccess -- Ok if one points to another | Just (_, Var other) <- p1, getName other == n2 -> pure ResSuccess | Just (_, Var other) <- p2, getName other == n1 -> pure ResSuccess | Just (v1, _) <- p1 , Just (v2, _) <- p2 , let slice1 = slice binds v1 , let slice2 = slice binds v2 -> if eqSlice ignore_types slice1 slice2 -- OK if they have the same expression then pure ResSuccess -- Not ok if the expression differ else pure . ResFailure $ pprSliceDifference slice1 slice2 -- Not ok if both names are bound externally | Nothing <- p1 , Nothing <- p2 -> pure . ResFailure $ ppr n1 <+> text " and " <+> ppr n2 <+> text "are different external names" | Nothing <- p1 -> pure . ResFailure $ ppr n1 <+> text "is an external name" | Nothing <- p2 -> pure . ResFailure $ ppr n2 <+> text "is an external name" where binds = flattenBinds (mg_binds guts) checkProperty guts thn (NoUseOf thns) = do n <- fromTHName thn ns <- mapM fromTHName thns case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case freeOfTerm (slice binds v) ns of Just _ -> pure . ResFailure $ pprSlice (slice binds v) Nothing -> pure ResSuccess where binds = flattenBinds (mg_binds guts) checkProperty guts thn (NoTypes thts) = do n <- fromTHName thn ts <- mapM fromTHName thts case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case freeOfType (slice binds v) ts of Just _ -> pure . ResFailure $ pprSlice (slice binds v) Nothing -> pure ResSuccess where binds = flattenBinds (mg_binds guts) checkProperty guts thn NoAllocation = do n <- fromTHName thn case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotAllocate (slice binds v) of Just (v',e') -> pure . ResFailure $ nest 4 (ppr v' <+> text "=" <+> ppr e') Nothing -> pure ResSuccess where binds = flattenBinds (mg_binds guts) checkProperty guts thn (NoTypeClasses thts) = do n <- fromTHName thn ts <- mapM fromTHName thts case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotContainTypeClasses (slice binds v) ts of Just (v',e') -> pure . ResFailure $ nest 4 (ppr v' <+> text "=" <+> ppr e') Nothing -> pure ResSuccess where binds = flattenBinds (mg_binds guts) checkProperty guts thn CoreOf = do n <- fromTHName thn case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> do let s = slice binds v pure $ ResSuccessWithMessage $ nest 4 $ pprSlice s where binds = flattenBinds (mg_binds guts) fromTHName :: TH.Name -> CoreM Name fromTHName thn = thNameToGhcName thn >>= \case Nothing -> do errorMsg $ text "Could not resolve TH name" <+> text (show thn) liftIO $ exitFailure -- kill the compiler. Is there a nicer way? Just n -> return n storeResults :: Updates -> ModGuts -> CoreM ModGuts storeResults = flip (foldM (flip (uncurry go))) where go :: Name -> Result -> ModGuts -> CoreM ModGuts go name res guts = do e <- resultToExpr res pure $ updateNameInGuts name e guts dcExpr :: TH.Name -> CoreM CoreExpr dcExpr thn = do name <- fromTHName thn dc <- lookupDataCon name pure $ Var (dataConWrapId dc) resultToExpr :: Result -> CoreM CoreExpr resultToExpr (Success s) = App <$> dcExpr 'Success <*> mkStringExpr s resultToExpr (Failure s) = App <$> dcExpr 'Failure <*> mkStringExpr s proofPass :: UponFailure -> ReportingMode -> ModGuts -> CoreM ModGuts proofPass upon_failure report guts = do dflags <- getDynFlags let noopt = optLevel dflags < 1 when noopt $ warnMsg $ fsep $ map text $ words "Test.Inspection: Compilation without -O detected. Expect optimizations to fail." let (guts', obligations) = extractObligations guts (toStore, stats) <- (concat `bimap` M.unionsWith (+)) . unzip <$> mapM (checkObligation report guts') obligations let n = sum stats :: Int guts'' <- storeResults toStore guts' let q :: Stat -> Int q s = fromMaybe 0 $ M.lookup s stats let summary_message = nest 2 $ vcat [ nest 2 (desc s) Outputable.<> colon <+> ppr (q s) | s <- [minBound..maxBound], q s > 0 ] -- Only print a message if there are some compile-time results to report unless (q StoredResult == n) $ do if q ExpSuccess + q ExpFailure + q StoredResult == n then unless (report == Quiet) $ putMsg $ text "inspection testing successful" $$ summary_message else do errorMsg $ text "inspection testing unsuccessful" $$ summary_message case upon_failure of KeepGoing -> return () KeepGoingO0 | noopt -> return () _ -> liftIO $ exitFailure -- kill the compiler. Is there a nicer way? return guts'' desc :: Stat -> SDoc desc ExpSuccess = text " expected successes" desc UnexpSuccess = text "unexpected successes" desc ExpFailure = text " expected failures" desc UnexpFailure = text " unexpected failures" desc StoredResult = text " results stored" partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b]) partitionMaybe f = partitionEithers . map (\x -> maybe (Left x) Right (f x)) -- | like prettySrcLoc, but omits the module name myPrettySrcLoc :: TH.Loc -> String myPrettySrcLoc TH.Loc {..} = foldr (++) "" [ loc_filename, ":" , show (fst loc_start), ":" , show (snd loc_start) ] inspection-testing-0.4.2.1/src/Test/Inspection/Core.hs0000644000000000000000000002650313476412656020761 0ustar0000000000000000-- | This module implements some analyses of Core expressions necessary for -- "Test.Inspection". Normally, users of this package can ignore this module. {-# LANGUAGE CPP, FlexibleContexts #-} module Test.Inspection.Core ( slice , pprSlice , pprSliceDifference , eqSlice , freeOfType , freeOfTerm , doesNotAllocate , doesNotContainTypeClasses ) where import CoreSyn import CoreUtils import TyCoRep import Type import Var import Id import Name import VarEnv import Outputable import PprCore import Coercion import Util import DataCon import TyCon (TyCon, isClassTyCon) import qualified Data.Set as S import Control.Monad.State.Strict import Control.Monad.Trans.Maybe import Data.Maybe type Slice = [(Var, CoreExpr)] -- | Selects those bindings that define the given variable (with this variable first) slice :: [(Var, CoreExpr)] -> Var -> Slice slice binds v | Just e <- lookup v binds = (v,e) : [(v',e) | (v',e) <- binds, v' /= v, v' `S.member` used ] | otherwise = error "slice: cannot find given variable in bindings" where used = execState (goV v) S.empty local = S.fromList (map fst binds) goV v | v `S.member` local = do seen <- gets (v `S.member`) unless seen $ do modify (S.insert v) let Just e = lookup v binds go e | otherwise = return () go (Var v) = goV v go (Lit _ ) = pure () go (App e arg) | isTyCoArg arg = go e go (App e arg) = go e >> go arg go (Lam _ e) = go e go (Let bind body) = mapM_ go (rhssOfBind bind) >> go body go (Case s _ _ alts) = go s >> mapM_ goA alts go (Cast e _) = go e go (Tick _ e) = go e go (Type _) = pure () go (Coercion _) = pure () goA (_, _, e) = go e -- | Pretty-print a slice pprSlice :: Slice -> SDoc pprSlice slice = withLessDetail $ pprCoreBindings [ NonRec v e | (v,e) <- slice ] -- | Pretty-print two slices, after removing variables occurring in both pprSliceDifference :: Slice -> Slice -> SDoc pprSliceDifference slice1 slice2 = nest 4 (hang (text "LHS" Outputable.<> colon) 4 (pprSlice slice1')) $$ nest 4 (hang (text "RHS" Outputable.<> colon) 4 (pprSlice slice2')) where both = S.intersection (S.fromList (map fst slice1)) (S.fromList (map fst slice2)) slice1' = filter (\(v,_) -> v `S.notMember` both) slice1 slice2' = filter (\(v,_) -> v `S.notMember` both) slice2 withLessDetail :: SDoc -> SDoc #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) withLessDetail sdoc = sdocWithDynFlags $ \dflags -> withPprStyle (defaultUserStyle dflags) sdoc #else withLessDetail sdoc = withPprStyle defaultUserStyle sdoc #endif type VarPair = (Var, Var) type VarPairSet = S.Set VarPair -- | This is a heuristic, which only works if both slices -- have auxiliary variables in the right order. -- (This is mostly to work-around the buggy CSE in GHC-8.0) -- It also breaks if there is shadowing. eqSlice :: Bool {- ^ ignore types -} -> Slice -> Slice -> Bool eqSlice _ slice1 slice2 | null slice1 || null slice2 = null slice1 == null slice2 -- Mostly defensive programming (slices should not be empty) eqSlice it slice1 slice2 = step (S.singleton (fst (head slice1), fst (head slice2))) S.empty where step :: VarPairSet -> VarPairSet -> Bool step wanted done | wanted `S.isSubsetOf` done = True -- done | (x,y) : _ <- S.toList (wanted `S.difference` done) , (Just _, wanted') <- runState (runMaybeT (equate x y)) wanted = step wanted' (S.insert (x,y) done) | otherwise = False equate :: Var -> Var -> MaybeT (State VarPairSet) () equate x y | Just e1 <- lookup x slice1 , Just x' <- essentiallyVar e1 , x' `elem` map fst slice1 = lift $ modify (S.insert (x',y)) | Just e2 <- lookup y slice2 , Just y' <- essentiallyVar e2 , y' `elem` map fst slice2 = lift $ modify (S.insert (x,y')) | Just e1 <- lookup x slice1 , Just e2 <- lookup y slice2 = go (mkRnEnv2 emptyInScopeSet) e1 e2 equate _ _ = mzero equated :: Var -> Var -> MaybeT (State VarPairSet) () equated x y | x == y = return () equated x y = lift $ modify (S.insert (x,y)) essentiallyVar :: CoreExpr -> Maybe Var essentiallyVar (App e a) | it, isTyCoArg a = essentiallyVar e essentiallyVar (Lam v e) | it, isTyCoVar v = essentiallyVar e essentiallyVar (Cast e _) | it = essentiallyVar e essentiallyVar (Var v) = Just v essentiallyVar _ = Nothing go :: RnEnv2 -> CoreExpr -> CoreExpr -> MaybeT (State (S.Set (Var,Var))) () go env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = pure () | otherwise = equated v1 v2 go _ (Lit lit1) (Lit lit2) = guard $ lit1 == lit2 go env (Type t1) (Type t2) = guard $ eqTypeX env t1 t2 go env (Coercion co1) (Coercion co2) = guard $ eqCoercionX env co1 co2 go env (Cast e1 _) e2 | it = go env e1 e2 go env e1 (Cast e2 _) | it = go env e1 e2 go env (Cast e1 co1) (Cast e2 co2) = do guard (eqCoercionX env co1 co2) go env e1 e2 go env (App e1 a) e2 | it, isTyCoArg a = go env e1 e2 go env e1 (App e2 a) | it, isTyCoArg a = go env e1 e2 go env (App f1 a1) (App f2 a2) = go env f1 f2 >> go env a1 a2 go env (Tick n1 e1) (Tick n2 e2) = guard (go_tick env n1 n2) >> go env e1 e2 go env (Lam b e1) e2 | it, isTyCoVar b = go env e1 e2 go env e1 (Lam b e2) | it, isTyCoVar b = go env e1 e2 go env (Lam b1 e1) (Lam b2 e2) = do guard (it || eqTypeX env (varType b1) (varType b2)) -- False for Id/TyVar combination go (rnBndr2 env b1 b2) e1 e2 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) = do go env r1 r2 -- No need to check binder types, since RHSs match go (rnBndr2 env v1 v2) e1 e2 go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) = do guard $ equalLength ps1 ps2 sequence_ $ zipWith (go env') rs1 rs2 go env' e1 e2 where (bs1,rs1) = unzip ps1 (bs2,rs2) = unzip ps2 env' = rnBndrs2 env bs1 bs2 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) | null a1 -- See Note [Empty case alternatives] in TrieMap = do guard (null a2) go env e1 e2 guard (it || eqTypeX env t1 t2) | otherwise = do guard $ equalLength a1 a2 go env e1 e2 sequence_ $ zipWith (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = guard False ----------- go_alt env (c1, bs1, e1) (c2, bs2, e2) = guard (c1 == c2) >> go (rnBndrs2 env bs1 bs2) e1 e2 go_tick :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool go_tick env (Breakpoint lid lids) (Breakpoint rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids go_tick _ l r = l == r -- | Returns @True@ if the given core expression mentions no type constructor -- anywhere that has the given name. freeOfType :: Slice -> [Name] -> Maybe (Var, CoreExpr) freeOfType slice tcNs = allTyCons (\tc -> getName tc `notElem` tcNs) slice allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr) allTyCons predicate slice = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ] where goV v = goT (varType v) go (Var v) = goV v go (Lit _ ) = True go (App e a) = go e && go a go (Lam b e) = goV b && go e go (Let bind body) = all goB (flattenBinds [bind]) && go body go (Case s b _ alts) = go s && goV b && all goA alts go (Cast e _) = go e go (Tick _ e) = go e go (Type t) = (goT t) go (Coercion _) = True goB (b, e) = goV b && go e goA (_,pats, e) = all goV pats && go e goT (TyVarTy _) = True goT (AppTy t1 t2) = goT t1 && goT t2 goT (TyConApp tc ts) = predicate tc && all goT ts -- ↑ This is the crucial bit goT (ForAllTy _ t) = goT t #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) goT (FunTy t1 t2) = goT t1 && goT t2 #endif goT (LitTy _) = True goT (CastTy t _) = goT t goT (CoercionTy _) = True -- -- | Returns @True@ if the given core expression mentions no term variable -- anywhere that has the given name. freeOfTerm :: Slice -> [Name] -> Maybe (Var, CoreExpr) freeOfTerm slice needles = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ] where isNeedle n = n `elem` needles goV v | isNeedle (Var.varName v) = False | Just dc <- isDataConId_maybe v , isNeedle (dataConName dc) = False | otherwise = True go (Var v) = goV v go (Lit _ ) = True go (App e a) = go e && go a go (Lam _ e) = go e go (Let bind body) = all goB (flattenBinds [bind]) && go body go (Case s _ _ alts) = go s && all goA alts go (Cast e _) = go e go (Tick _ e) = go e go (Type _) = True go (Coercion _) = True goB (_, e) = go e goA (ac, _, e) = goAltCon ac && go e goAltCon (DataAlt dc) | isNeedle (dataConName dc) = False goAltCon _ = True -- | True if the given variable binding does not allocate, if called fully -- satisfied. -- -- It currently does not look through function calls, which of course could -- allocate. It should probably at least look through local function calls. -- -- The variable is important to know the arity of the function. doesNotAllocate :: Slice -> Maybe (Var, CoreExpr) doesNotAllocate slice = listToMaybe [ (v,e) | (v,e) <- slice, not (go (idArity v) e) ] where go _ (Var v) | isDataConWorkId v, idArity v > 0 = False go a (Var v) = a >= idArity v go _ (Lit _ ) = True go a (App e arg) | isTypeArg arg = go a e go a (App e arg) = go (a+1) e && goArg arg go a (Lam b e) | isTyVar b = go a e go 0 (Lam _ _) = False go a (Lam _ e) = go (a-1) e go a (Let bind body) = all goB (flattenBinds [bind]) && go a body go a (Case s _ _ alts) = go 0 s && all (goA a) alts go a (Cast e _) = go a e go a (Tick _ e) = go a e go _ (Type _) = True go _ (Coercion _) = True goArg e | exprIsTrivial e = go 0 e | isUnliftedType (exprType e) = go 0 e | otherwise = False goB (b, e) #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) | isJoinId b = go (idArity b) e #endif -- Not sure when a local function definition allocates… | isFunTy (idType b) = go (idArity b) e | isUnliftedType (idType b) = go (idArity b) e | otherwise = False -- A let binding allocates if any variable is not a join point and not -- unlifted goA a (_,_, e) = go a e doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr) doesNotContainTypeClasses slice tcNs = allTyCons (\tc -> not (isClassTyCon tc) || any (getName tc ==) tcNs) slice