inspection-testing-0.5.0.2/0000755000000000000000000000000007346545000013673 5ustar0000000000000000inspection-testing-0.5.0.2/ChangeLog.md0000644000000000000000000000656207346545000016055 0ustar0000000000000000# Revision history for inspection-testing ## 0.5.0.2 -- 2023-07-10 * Support GHC 9.8 (thanks Bodigrim) ## 0.5.0.1 -- 2023-01-15 * Support mtl-2.3 and GHC 9.6 (thanks Bodigrim) ## 0.5 -- 2022-06-15 * New equivalence `==~` that accepts different order of bindings in lets. (thanks @phadej) * When printing terms that differ, common up a common prefix of lambdas (thanks @phadej) ## 0.4.6.1 -- 2022-05-20 * Support GHC 9.4 (thanks @parsonsmatt) ## 0.4.6.0 -- 2020-08-23 * Support GHC 9.2 (thanks @Bodigrim) ## 0.4.5.0 -- 2020-04-28 * Export some internals from `Test.Inspection.Plugin`, to make integration into testing frameworks easier (thanks @Bodigrim) ## 0.4.4.0 -- 2020-04-21 * More GHC-9.0 compatibility (thanks @aadaa-fgtaa) ## 0.4.3.0 -- 2020-01-26 * Ignores HPC ticks in `(==-)` (thanks @konn) * Add `(=/-)` operator (thanks @lysxia) * Add skip-O0 plugin option (thanks @AndrasKovacs) * GHC-9.0 compatibility (thanks @konn) * CI now runs on Github Actions (thanks @phadej) ## 0.4.2.4 -- 2020-01-26 * Now prints the name of the type class on which a test fails, thanks to Harendra Kumar * More examples, thanks to Rafe ## 0.4.2.3 -- 2020-01-26 * Support GHC-8.10, thanks to Ryan Scott via head.hackage for the patch ## 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.5.0.2/LICENSE0000644000000000000000000000204407346545000014700 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.5.0.2/README.md0000644000000000000000000000621007346545000015151 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.5.0.2/Setup.hs0000644000000000000000000000005607346545000015330 0ustar0000000000000000import Distribution.Simple main = defaultMain inspection-testing-0.5.0.2/examples/0000755000000000000000000000000007346545000015511 5ustar0000000000000000inspection-testing-0.5.0.2/examples/Dictionary.hs0000644000000000000000000000170107346545000020151 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.5.0.2/examples/DoesNotUse.hs0000644000000000000000000000071607346545000020101 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.5.0.2/examples/Fusion.hs0000644000000000000000000000201607346545000017307 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -dsuppress-all -funfolding-use-threshold=120 #-} module Fusion (main) where import Test.Inspection import Data.List (foldl', sort) sumUp1 :: Int -> Bool sumUp1 n = sum [1..n] > 1000 inspect $ 'sumUp1 `hasNoType` ''[] inspect $ ('sumUp1 `hasNoType` ''Int) { expectFail = True } inspect $ mkObligation 'sumUp1 NoAllocation -- This stopped working in GHC-9.0, because -- * the > 1000 comparison is floated into the recursive join point (ok) -- * `sumUp2` is compiled with a worker-wrapper split that does not happen for -- sumUp1 (hard to fix) -- so I am disabling this part of the test on GHC-9.0 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) inspect $ 'sumUp1 === 'sumUp2 -- Example for a non-fusing funtion sumUpSort :: Int -> Int sumUpSort n = sum . sort $ [1..n] inspect $ ('sumUpSort `hasNoType` ''[]) { expectFail = True } main :: IO () main = return () inspection-testing-0.5.0.2/examples/GenericLens.hs0000644000000000000000000000251507346545000020246 0ustar0000000000000000{-# LANGUAGE RankNTypes, DeriveGeneric, TypeApplications, DataKinds, ExistentialQuantification, TemplateHaskell #-} {-# OPTIONS_GHC -dsuppress-idinfo #-} 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.5.0.2/examples/Generics.hs0000644000000000000000000000077607346545000017616 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.5.0.2/examples/HPCs.hs0000644000000000000000000000066007346545000016644 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O -fhpc -fplugin-opt=Test.Inspection.Plugin:quiet #-} module HPCs (main) where import Test.Inspection main :: IO () main = return () theTwo :: Int theTwo = 2 anotherTwo :: Int anotherTwo = 2 theOnePlusOne :: Int theOnePlusOne = 1 + 1 inspect $ 'theTwo ==- 'theOnePlusOne inspect $ 'theTwo ==- 'anotherTwo inspect $ 'theTwo =/= 'theOnePlusOne inspect $ 'theTwo =/= 'anotherTwo inspection-testing-0.5.0.2/examples/LetsTest.hs0000644000000000000000000000232607346545000017617 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -dsuppress-all #-} module Main (main) where import Test.Inspection import Data.Char (toUpper) import System.Exit lhs1, rhs1 :: Char -> Char -> String lhs1 x y = let x' = toUpper x y' = toUpper y in [x', x', y', y'] rhs1 x y = let y' = toUpper y x' = toUpper x in [x', x', y', y'] -- recursive lhs2, rhs2, rhs2b :: String lhs2 = let zs = 'z' : xs xs = 'x' : ys ys = 'y' : xs in zs rhs2 = let ys = 'y' : xs xs = 'x' : ys zs = 'z' : xs in zs rhs2b = let ys = 'y' : xs xs = 'x' : ys zs = 'z' : ys in zs 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 $ 'lhs1 ==~ 'rhs1) , $(inspectTest $ 'lhs2 ==- 'rhs2) -- here GHC orders let bindings by itself! , $(inspectTest $ 'lhs2 =/~ 'rhs2b) ] main :: IO () main = do mapM_ printResult results if map isSuccess results == [True, True, False] then exitSuccess else exitFailure inspection-testing-0.5.0.2/examples/MutualRecursion.hs0000644000000000000000000005644607346545000021225 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.5.0.2/examples/NS_NP.hs0000644000000000000000000000176207346545000016770 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, DataKinds, PolyKinds, TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -O -fplugin-opt=Test.Inspection.Plugin:quiet -Wno-overlapping-patterns #-} 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.5.0.2/examples/Regression.hs0000644000000000000000000000047607346545000020174 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.5.0.2/examples/Simple.hs0000644000000000000000000000042407346545000017276 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.5.0.2/examples/SimpleTest.hs0000644000000000000000000000134407346545000020140 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.5.0.2/examples/Text.hs0000644000000000000000000000141307346545000016770 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.5.0.2/examples/UnsafeCoerce.hs0000644000000000000000000000046507346545000020414 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module UnsafeCoerce (main) where import Test.Inspection import Unsafe.Coerce import GHC.Exts lhs :: Any -> Any lhs a = unsafeCoerce $ unsafeCoerce a + (1 :: Int) rhs :: Int -> Int rhs = (+ 1) inspect $ 'lhs =/= 'rhs inspect $ 'lhs ==- 'rhs main :: IO () main = return () inspection-testing-0.5.0.2/examples/WorkerWrapper.hs0000644000000000000000000000312107346545000020654 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module WorkerWrapper (main) where import Test.Inspection -- In this module, we are interested in checking if the worker-wrapper transformation is firing. -- That transformation is described here: -- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/demand#worker-wrapper-split -- In short, we don't want to be passing around the dictionary type below, but rather have GHC -- generate a helper function @$wdictFold :: (m -> m -> m) -> m -> [m] -> m@, as this saves us some -- wrapping and unwrapping work at each iteration. -- -- GHC still generates a wrapper at the @dictFold@ name. That is, a function that still consumes the -- @MonoidDict@ type, but unwraps it just once, before passing it off to @wdictFold@ to handle the -- recuresion. As @dictFold@ refers to this wrapper, we cannot check that the @MonoidDict@ type is -- unused in its definition. -- -- So what are we to do? As the generated wrapper should have an @INLINE@ pragma, once we pass it in -- the @MonoidDict@, we should be safely in worker-land, and not need to reference @MonoidDict@ -- again. Thus, we look at @appliedFold@, and assert that @MonoidDict@ never shows up -- as would be -- expected if worker-wrapper fired as hoped. data MonoidDict a = MonoidDict { dictMappend :: a -> a -> a, dictMempty :: a } dictFold :: MonoidDict m -> [m] -> m dictFold bm xs = case xs of [] -> dictMempty bm x:xs' -> dictMappend bm x $ dictFold bm xs' appliedFold :: [Int] -> Int appliedFold = dictFold $ MonoidDict (+) 0 inspect $ 'appliedFold `doesNotUse` 'MonoidDict main :: IO () main = return () inspection-testing-0.5.0.2/inspection-testing.cabal0000644000000000000000000002033307346545000020506 0ustar0000000000000000name: inspection-testing version: 0.5.0.2 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.*, GHC ==8.8.*, GHC ==8.10.*, GHC ==9.0.*, GHC ==9.2.*, GHC ==9.4.*, GHC ==9.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.20 build-depends: ghc >= 8.0.2 && <9.9 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 default-language: Haskell2010 ghc-options: -main-is NS_NP if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite HPCs type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: HPCs.hs build-depends: inspection-testing build-depends: base default-language: Haskell2010 ghc-options: -main-is HPCs 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 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 default-language: Haskell2010 if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite lets-test type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: LetsTest.hs build-depends: inspection-testing build-depends: base 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 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 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 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 default-language: Haskell2010 ghc-options: -main-is Dictionary 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 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 default-language: Haskell2010 if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite worker-wrapper type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: WorkerWrapper.hs build-depends: inspection-testing build-depends: base default-language: Haskell2010 ghc-options: -main-is WorkerWrapper if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin test-suite unsafe-coerce type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: UnsafeCoerce.hs build-depends: inspection-testing build-depends: base default-language: Haskell2010 ghc-options: -main-is UnsafeCoerce 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 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 build-depends: generic-lens ==2.1.0.0 else buildable: False default-language: Haskell2010 ghc-options: -main-is GenericLens if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin flag old-text-tests description: Run tests that exhibits bug in old text package. Only works with older version of GHC. default: False test-suite text type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Text.hs if flag(old-text-tests) build-depends: inspection-testing build-depends: base 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 inspection-testing-0.5.0.2/src/Test/0000755000000000000000000000000007346545000015401 5ustar0000000000000000inspection-testing-0.5.0.2/src/Test/Inspection.hs0000644000000000000000000002565307346545000020063 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 -- $synopsis -- * Registering obligations inspect, inspectTest, Result(..), -- * Defining obligations Obligation(..), mkObligation, Equivalence (..), 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) {- $synopsis 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: @ {-\# OPTIONS_GHC -fplugin=Test.Inspection.Plugin \#-} @ -} -- 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' or 'inspectTest'. -- -- @since 0.1 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. -- -- @since 0.2 } deriving Data -- | Properties of the obligation target to be checked. -- -- @since 0.1 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. -- -- The `Equivalence` indicates how strict to check for equality = EqualTo Name Equivalence -- | Do none of these types appear anywhere in the definition of the function -- (neither locally bound nor passed as arguments) -- -- @since 0.3 | NoTypes [Name] -- | Does this function perform no heap allocations. | NoAllocation -- | Does this value contain dictionaries (/except/ of the listed classes). -- -- @since 0.3 | NoTypeClasses [Name] -- | Does not contain this value (in terms or patterns) -- -- @since 0.4.1 | NoUseOf [Name] -- | Always satisfied, but dumps the value in non-quiet mode. -- -- @since 0.4.2 | CoreOf deriving Data -- | Equivalence of terms. -- -- @since 0.5 data Equivalence = StrictEquiv -- ^ strict term equality | IgnoreTypesAndTicksEquiv -- ^ ignore types and hpc ticks during the comparison | UnorderedLetsEquiv -- ^ allow permuted let bindings, ignore types and hpc tick during comparison deriving Data -- | Creates an inspection obligation for the given function name -- with default values for the optional fields. -- -- @since 0.1 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') -- -- @since 0.1 (===) :: Name -> Name -> Obligation (===) = mkEquality False StrictEquiv infix 9 === -- | Declare two functions to be equal, but ignoring -- type lambdas, type arguments, type casts and hpc ticks (see 'EqualTo'). -- Note that @-fhpc@ can prevent some optimizations; build without for more reliable analysis. -- -- @since 0.1.1 (==-) :: Name -> Name -> Obligation (==-) = mkEquality False IgnoreTypesAndTicksEquiv infix 9 ==- -- | Declare two functions to be equal as @('==-')@ but also ignoring -- let bindings ordering (see 'EqualTo'). -- -- @since 0.5 (==~) :: Name -> Name -> Obligation (==~) = mkEquality False UnorderedLetsEquiv 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.) -- -- @since 0.1 (=/=) :: Name -> Name -> Obligation (=/=) = mkEquality True StrictEquiv infix 9 =/= -- | Declare two functions to be equal up to types (see '(==-)'), -- but expect the test to fail (see 'expectFail'). -- -- @since 0.4.3.0 (=/-) :: Name -> Name -> Obligation (=/-) = mkEquality False IgnoreTypesAndTicksEquiv infix 9 =/- -- | Declare two functions to be equal up to let binding ordering (see '(==~)'), -- but expect the test to fail (see 'expectFail'). -- -- @since 0.5 (=/~) :: Name -> Name -> Obligation (=/~) = mkEquality False UnorderedLetsEquiv infix 9 =/~ mkEquality :: Bool -> Equivalence -> 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`` ''[]@ -- -- @since 0.1 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 'hasNoType' applied to the usual type constructors used in -- "GHC.Generics". -- -- @inspect $ hasNoGenerics genericFunction@ -- -- @since 0.3 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@ -- -- @since 0.3 hasNoTypeClasses :: Name -> Obligation hasNoTypeClasses n = hasNoTypeClassesExcept n [] -- | A variant of 'hasNoTypeClasses', which white-lists some type-classes. -- -- @'inspect' $ fieldLens ``hasNoTypeClassesExcept`` [''Functor]@ -- -- @since 0.3 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@ -- -- @since 0.4.1 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. -- -- @since 0.4.2 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. -- -- @since 0.1 inspect :: Obligation -> Q [Dec] inspect = inspectCommon ModuleAnnotation -- | The result of 'inspectTest', which has a more or less helpful text message -- -- @since 0.2 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 of 'inspect' 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@](https://hackage.haskell.org/package/tasty-expected-failure)) -- -- @since 0.2 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.5.0.2/src/Test/Inspection/0000755000000000000000000000000007346545000017514 5ustar0000000000000000inspection-testing-0.5.0.2/src/Test/Inspection/Core.hs0000644000000000000000000005031507346545000020744 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, PatternSynonyms, MultiWayIf #-} module Test.Inspection.Core ( slice , pprSlice , pprSliceDifference , eqSlice , freeOfType , freeOfTerm , doesNotAllocate , doesNotContainTypeClasses ) where #if MIN_VERSION_ghc(9,0,0) import GHC.Core import GHC.Core.Utils import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Types.Var as Var import GHC.Types.Id import GHC.Types.Name import GHC.Types.Literal import GHC.Types.Var.Env import GHC.Types.Unique import GHC.Utils.Outputable as Outputable import GHC.Core.Ppr import GHC.Core.Subst import GHC.Core.Coercion import GHC.Utils.Misc import GHC.Core.DataCon import GHC.Core.TyCon (TyCon, isClassTyCon) #else import CoreSyn import CoreUtils import CoreSubst import TyCoRep import Type import Var import Id import Literal import Name import VarEnv import Outputable import PprCore import Coercion import Util import DataCon import Unique import TyCon (TyCon, isClassTyCon) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Types.Tickish #endif #if MIN_VERSION_ghc(9,6,0) import GHC.Core.TyCo.Compare (eqTypeX) #endif import qualified Data.Set as S import Control.Monad (guard, unless, mzero) import Control.Monad.Trans.Class (lift) import Control.Monad.State.Strict (StateT, runStateT, execState, modify, modify', put, get, gets) import Data.List (nub, intercalate) import Data.Maybe import Test.Inspection (Equivalence (..)) -- Uncomment to enable debug traces -- import Debug.Trace tracePut :: Monad m => Int -> String -> String -> m () -- tracePut lv name msg = traceM $ replicate lv ' ' ++ name ++ ": " ++ msg tracePut _ _ _ = return () #if !MIN_VERSION_ghc(9,2,0) pattern Alt :: a -> b -> c -> (a, b, c) pattern Alt a b c = (a, b, c) {-# COMPLETE Alt #-} #endif 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 e = fromJust $ 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 (Alt _ _ 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 | [(v1,e1)] <- slice1' , [(v2,e2)] <- slice2' = pprSingletonSliceDifference v1 v2 e1 e2 | otherwise = hang (text "LHS" Outputable.<> colon) 4 (pprSlice slice1') $$ 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 pprSingletonSliceDifference :: Var -> Var -> CoreExpr -> CoreExpr -> SDoc pprSingletonSliceDifference v1 v2 e1 e2 = ctxDoc $ hang (text "LHS" Outputable.<> colon) 4 (hang (pprPrefixOcc v1) 2 (eqSign <+> pprCoreExpr e1')) $$ hang (text "RHS" Outputable.<> colon) 4 (hang (pprPrefixOcc v2) 2 (eqSign <+> pprCoreExpr e2')) where hasContext = not (null ctxt) ctxDoc | hasContext = id | otherwise = (hang (text "In") 4 (ppr $ mkContextExpr (reverse (map snd ctxt))) $$) eqSign | hasContext = text "= ..." | otherwise = equals (e1', e2', ctxt) = go e1 e2 [] (mkRnEnv2 emptyInScopeSet) go :: CoreExpr -> CoreExpr -> [(Var, Var)] -> RnEnv2 -> (CoreExpr, CoreExpr, [(Var, Var)]) go (Lam b1 t1) (Lam b2 t2) ctxt env | eqTypeX env (varType b1) (varType b2) = go t1 t2 ((b1,b2):ctxt) (rnBndr2 env b1 b2) where go x y ctxt _env = (rename ctxt x, y, ctxt) mkContextExpr :: [Var] -> CoreExpr mkContextExpr [] = ellipsis mkContextExpr (x:rest) = Lam x (mkContextExpr rest) ellipsis :: CoreExpr #if MIN_VERSION_ghc(8,8,0) ellipsis = Lit $ mkLitString "..." #else ellipsis = Lit $ mkMachString "..." #endif withLessDetail :: SDoc -> SDoc #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,0,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 :: Equivalence -> Slice -> Slice -> Bool eqSlice _ slice1 slice2 | null slice1 || null slice2 = null slice1 == null slice2 -- Mostly defensive programming (slices should not be empty) eqSlice eqv slice1 slice2 -- slices are equal if there exist any result with no "unification" obligations left. = any (S.null . snd) results where -- ignore types and hpc ticks it :: Bool it = case eqv of StrictEquiv -> False IgnoreTypesAndTicksEquiv -> True UnorderedLetsEquiv -> True -- unordered lets ul :: Bool ul = case eqv of StrictEquiv -> False IgnoreTypesAndTicksEquiv -> False UnorderedLetsEquiv -> True -- results. If there are no pairs to be equated, all is fine. results :: [((), VarPairSet)] results = runStateT (loop' (mkRnEnv2 emptyInScopeSet) S.empty (fst (head slice1)) (fst (head slice2))) S.empty -- while there are obligations left, try to equate them. loop :: RnEnv2 -> VarPairSet -> StateT VarPairSet [] () loop env done = do vars <- get case S.minView vars of Nothing -> return () -- nothing to do, done. Just ((x, y), vars') -> do put vars' if (x, y) `S.member` done then loop env done else loop' env done x y loop' :: RnEnv2 -> VarPairSet -> Var -> Var -> StateT VarPairSet [] () loop' env done x y = do tracePut 0 "TOP" (varToString x ++ " =?= " ++ varToString y) tracePut 0 "DONESET" (showVarPairSet done) -- if x or y expressions are essentially a variable x' or y' respectively -- add an obligation to check x' = y (or x = y'). if | Just e1 <- lookup x slice1 , Just x' <- essentiallyVar e1 , x' `elem` map fst slice1 -> do modify' (S.insert (x', y)) loop env done | Just e2 <- lookup y slice2 , Just y' <- essentiallyVar e2 , y' `elem` map fst slice2 -> do modify' (S.insert (x, y')) loop env done -- otherwise if neither x and y expressions are variables -- 1. compare the expressions (already assuming that x and y are equal) -- 2. comparison may create new obligations, loop. | Just e1 <- lookup x slice1 , Just e2 <- lookup y slice2 -> do let env' = rnBndr2 env x y done' = S.insert (x, y) done go 0 env' e1 e2 loop env' done' -- and finally, if x or y are not in the slice, we abort. | otherwise -> do tracePut 0 "TOP" (varToString x ++ " =?= " ++ varToString y ++ " NOT IN SLICES") mzero 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 #if MIN_VERSION_ghc(9,0,0) essentiallyVar (Case s _ _ [Alt _ _ e]) | it, isUnsafeEqualityProof s = essentiallyVar e #endif essentiallyVar (Var v) = Just v essentiallyVar (Tick HpcTick{} e) | it = essentiallyVar e essentiallyVar _ = Nothing go :: Int -> RnEnv2 -> CoreExpr -> CoreExpr -> StateT VarPairSet [] () go lv env (Var v1) (Var v2) = do if | v1 == v2 -> do tracePut lv "VAR" (varToString v1 ++ " =?= " ++ varToString v2 ++ " SAME") return () | rnOccL env v1 == rnOccR env v2 -> do tracePut lv "VAR" (varToString v1 ++ " =?= " ++ varToString v2 ++ " IN ENV") return () | otherwise -> do tracePut lv "VAR" (varToString v1 ++ " =?= " ++ varToString v2 ++ " OBLIGATION") modify (S.insert (v1, v2)) go lv _ (Lit lit1) (Lit lit2) = do tracePut lv "LIT" "???" -- no Show for Literal :( 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 lv env (Cast e1 _) e2 | it = go lv env e1 e2 go lv env e1 (Cast e2 _) | it = go lv env e1 e2 #if MIN_VERSION_ghc(9,0,0) go lv env (Case s _ _ [Alt _ _ e1]) e2 | it, isUnsafeEqualityProof s = go lv env e1 e2 go lv env e1 (Case s _ _ [Alt _ _ e2]) | it, isUnsafeEqualityProof s = go lv env e1 e2 #endif go lv env (Cast e1 co1) (Cast e2 co2) = traceBlock lv "CAST" "" $ \lv -> do guard (eqCoercionX env co1 co2) go lv env e1 e2 go lv env (App e1 a) e2 | it, isTyCoArg a = go lv env e1 e2 go lv env e1 (App e2 a) | it, isTyCoArg a = go lv env e1 e2 go lv env (App f1 a1) (App f2 a2) = traceBlock lv "APP" "" $ \lv -> do go lv env f1 f2 go lv env a1 a2 go lv env (Tick HpcTick{} e1) e2 | it = go lv env e1 e2 go lv env e1 (Tick HpcTick{} e2) | it = go lv env e1 e2 go lv env (Tick n1 e1) (Tick n2 e2) = traceBlock lv "TICK" "" $ \lv -> do guard (go_tick env n1 n2) go lv env e1 e2 go lv env (Lam b e1) e2 | it, isTyCoVar b = go lv env e1 e2 go lv env e1 (Lam b e2) | it, isTyCoVar b = go lv env e1 e2 go lv env (Lam b1 e1) (Lam b2 e2) = traceBlock lv "LAM" (varToString b1 ++ " ~ " ++ varToString b2) $ \lv -> do guard (it || eqTypeX env (varType b1) (varType b2)) go lv (rnBndr2 env b1 b2) e1 e2 go lv env e1@(Let _ _) e2@(Let _ _) | ul , (ps1, e1') <- peelLets e1 , (ps2, e2') <- peelLets e2 = traceBlock lv "LET" (showVars ps1 ++ " ~ " ++ showVars ps2) $ \lv -> do guard $ equalLength ps1 ps2 env' <- goBinds lv env ps1 ps2 go lv env' e1' e2' go lv env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) = do go lv env r1 r2 -- No need to check binder types, since RHSs match go lv (rnBndr2 env v1 v2) e1 e2 go lv env (Let (Rec ps1) e1) (Let (Rec ps2) e2) = do guard $ equalLength ps1 ps2 sequence_ $ zipWith (go lv env') rs1 rs2 go lv env' e1 e2 where (bs1,rs1) = unzip ps1 (bs2,rs2) = unzip ps2 env' = rnBndrs2 env bs1 bs2 go lv 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 lv env e1 e2 guard (it || eqTypeX env t1 t2) | otherwise = do guard $ equalLength a1 a2 go lv env e1 e2 sequence_ $ zipWith (go_alt lv (rnBndr2 env b1 b2)) a1 a2 go lv _ e1 e2 = do tracePut lv "FAIL" (conToString e1 ++ " =/= " ++ conToString e2) mzero ----------- go_alt lv env (Alt c1 bs1 e1) (Alt c2 bs2 e2) = guard (c1 == c2) >> go lv (rnBndrs2 env bs1 bs2) e1 e2 go_tick :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool go_tick env Breakpoint{ breakpointId = lid, breakpointFVs = lids } Breakpoint{ breakpointId = rid, breakpointFVs = rids } = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids go_tick _ l r = l == r peelLets (Let (NonRec v r) e) = let (xs, e') = peelLets e in ((v,r):xs, e') peelLets (Let (Rec bs) e) = let (xs, e') = peelLets e in (bs ++ xs, e') peelLets e = ([], e) goBinds :: Int -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] -> StateT VarPairSet [] RnEnv2 goBinds _ env [] [] = return env goBinds _ _ [] (_:_) = mzero goBinds lv env ((v1,b1):xs) ys' = do -- select a binding ((v2,b2), ys) <- lift (choices ys') traceBlock lv "LET*" (varToString v1 ++ " =?= " ++ varToString v2) $ \lv -> go lv env b1 b2 -- if match succeeds, delete it from the obligations modify (S.delete (v1, v2)) -- continue with the rest of bindings, adding a pair as matching one. goBinds lv (rnBndr2 env v1 v2) xs ys #if !MIN_VERSION_ghc(9,2,0) type CoreTickish = Tickish Id #endif traceBlock :: Monad m => Int -> String -> String -> (Int -> m ()) -> m () traceBlock lv name msg action = do tracePut lv name msg action (lv + 1) tracePut lv name $ msg ++ " OK" showVars :: [(Var, a)] -> String showVars xs = intercalate ", " [ varToString x | (x, _) <- xs ] showVarPairSet :: VarPairSet -> String showVarPairSet xs = intercalate ", " [ varToString x ++ " ~ " ++ varToString y | (x, y) <- S.toList xs ] varToString :: Var -> String varToString v = occNameString (occName (tyVarName v)) ++ "_" ++ show (getUnique v) -- using tyVarName as varName is ambiguous. conToString :: CoreExpr -> [Char] conToString Var {} = "Var" conToString Lit {} = "Lit" conToString App {} = "App" conToString Lam {} = "Lam" conToString Let {} = "Let" conToString Case {} = "Case" conToString Cast {} = "Cast" conToString Tick {} = "Tick" conToString Type {} = "Type" conToString Coercion {} = "Coercion" -- | -- -- >>> choices "" -- [] -- -- >>> choices "abcde" -- [('a',"bcde"),('b',"acde"),('c',"abde"),('d',"abce"),('e',"abcd")] -- choices :: [a] -> [(a, [a])] choices = go id where go :: ([a] -> [a]) -> [a] -> [(a, [a])] go _ [] = [] go f (x:xs) = (x, f xs) : go (f . (x :)) xs -- | 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 = fmap (\(a,b,_) -> (a,b)) $ allTyCons (\tc -> getName tc `notElem` tcNs) slice -- | Check if all type constructors in a slice satisfy the given predicate. -- Returns the binder, expression and failing constructors triple on failure. allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr, [TyCon]) allTyCons ignore slice = listToMaybe [(v, e, nub tcs) | (v, e) <- slice, let tcs = go e, not (null tcs)] where goV v = goT (varType v) go (Var v) = goV v go (Lit _) = [] go (App e a) = go e ++ go a go (Lam b e) = goV b ++ go e go (Let bind body) = concatMap goB (flattenBinds [bind]) ++ go body go (Case s b _ alts) = go s ++ goV b ++ concatMap goA alts go (Cast e _) = go e go (Tick _ e) = go e go (Type t) = (goT t) go (Coercion _) = [] goB (b, e) = goV b ++ go e goA (Alt _ pats e) = concatMap goV pats ++ go e goT (TyVarTy _) = [] goT (AppTy t1 t2) = goT t1 ++ goT t2 goT (TyConApp tc ts) = [tc | not (ignore tc)] ++ concatMap goT ts -- ↑ This is the crucial bit goT (ForAllTy _ t) = goT t #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0) goT (FunTy #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) _ #endif # if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0) _ # endif t1 t2) = goT t1 ++ goT t2 #endif goT (LitTy _) = [] goT (CastTy t _) = goT t goT (CoercionTy _) = [] -- -- | 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 (Alt 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 (Alt _ _ e) = go a e doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr, [TyCon]) doesNotContainTypeClasses slice tcNs = allTyCons (\tc -> not (isClassTyCon tc) || any (getName tc ==) tcNs) slice rename :: [(Var, Var)] -> CoreExpr -> CoreExpr rename rn = substExpr' sub where -- convert RnEnv2 to Subst -- here we forget about tyvars and covars, but mostly this is good enough. sub = mkOpenSubst emptyInScopeSet [ (v1, if isTyVar v2 then Type (mkTyVarTy v2) else if isCoVar v2 then Coercion (mkCoVarCo v2) else Var v2 ) | (v1, v2) <- rn] #if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) substExpr' = substExpr #else substExpr' = substExpr empty #endif inspection-testing-0.5.0.2/src/Test/Inspection/Plugin.hs0000644000000000000000000003452007346545000021312 0ustar0000000000000000-- | See "Test.Inspection". -- {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE LambdaCase #-} module Test.Inspection.Plugin ( plugin , checkProperty , CheckResult(..) , prettyProperty ) 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 #if MIN_VERSION_ghc(9,4,0) import GHC.Types.Error import GHC.Driver.Session #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Plugins hiding (SrcLoc) import GHC.Utils.Outputable as Outputable #else import GhcPlugins hiding (SrcLoc) import Outputable #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Types.TyThing #endif import Test.Inspection (Obligation(..), Equivalence (..), Property(..), Result(..)) import Test.Inspection.Core -- | The plugin. It supports some options: -- -- * @-fplugin-opt=Test.Inspection.Plugin:keep-going@ to keep building despite failing obligations -- * @-fplugin-opt=Test.Inspection.Plugin:keep-going-O0@ to keep building despite failing obligations, when optimisations are off -- * @-fplugin-opt=Test.Inspection.Plugin:skip-O0@ to skip performing inspections when optimisations are off -- * @-fplugin-opt=Test.Inspection.Plugin:quiet@ to be silent if all obligations are fulfilled -- -- It makes sense to enable only one of @keep-going@, @keep-going-O0@ and -- @skip-O0@ at a time. @skip-O0@ is useful when working with GHCi, to suppress -- inspection failure messages and eliminate the overhead of inspection when -- loading. plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install #if __GLASGOW_HASKELL__ >= 806 , pluginRecompile = \_args -> pure NoForceRecompile #endif } data UponFailure = AbortCompilation | KeepGoingO0 | SkipO0 | 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 | "skip-O0" `elem` args = SkipO0 | 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 (showTHName mod) target property prettyProperty :: (TH.Name -> String) -> TH.Name -> Property -> String prettyProperty showName target = \case EqualTo n2 eqv -> showName target ++ " " ++ showEquiv eqv ++ " " ++ showName n2 NoTypes [t] -> showName target ++ " `hasNoType` " ++ showName t NoTypes ts -> showName target ++ " mentions none of " ++ intercalate ", " (map showName ts) NoAllocation -> showName target ++ " does not allocate" NoTypeClasses [] -> showName target ++ " does not contain dictionary values" NoTypeClasses ts -> showName target ++ " does not contain dictionary values except of " ++ intercalate ", " (map showName ts) NoUseOf ns -> showName target ++ " uses none of " ++ intercalate ", " (map showName ns) CoreOf -> showName target ++ " core dump" -- :) where showEquiv StrictEquiv = "===" showEquiv IgnoreTypesAndTicksEquiv = "==-" showEquiv UnorderedLetsEquiv = "==~" -- | 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',tc) -> pure . ResFailure $ nest 4 $ vcat [ text "Found type classes: " <+> ppr tc , 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 case upon_failure of SkipO0 -> pure guts _ -> do 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 () _ -> 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) ]