diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for inspection-testing +## 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 diff --git a/examples/MutualRecursion.hs b/examples/MutualRecursion.hs new file mode 100644 --- /dev/null +++ b/examples/MutualRecursion.hs @@ -0,0 +1,853 @@ +{-# 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 () + diff --git a/inspection-testing.cabal b/inspection-testing.cabal --- a/inspection-testing.cabal +++ b/inspection-testing.cabal @@ -1,5 +1,5 @@ name: inspection-testing -version: 0.4.1.2 +version: 0.4.2 synopsis: GHC plugin to do inspection testing description: Some carefully crafted libraries make promises to their users beyond functionality and performance. @@ -164,3 +164,12 @@ 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 diff --git a/src/Test/Inspection.hs b/src/Test/Inspection.hs --- a/src/Test/Inspection.hs +++ b/src/Test/Inspection.hs @@ -28,7 +28,7 @@ -- $convenience (===), (==-), (=/=), hasNoType, hasNoGenerics, hasNoTypeClasses, hasNoTypeClassesExcept, - doesNotUse, + doesNotUse, coreOf, ) where import Language.Haskell.TH @@ -127,6 +127,9 @@ -- | 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 @@ -211,6 +214,14 @@ 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 diff --git a/src/Test/Inspection/Core.hs b/src/Test/Inspection/Core.hs --- a/src/Test/Inspection/Core.hs +++ b/src/Test/Inspection/Core.hs @@ -34,9 +34,13 @@ type Slice = [(Var, CoreExpr)] --- | Selects those bindings that define the given variable +-- | Selects those bindings that define the given variable (with this variable first) slice :: [(Var, CoreExpr)] -> Var -> Slice -slice binds v = [(v,e) | (v,e) <- binds, v `S.member` used ] +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 @@ -65,7 +69,8 @@ -- | Pretty-print a slice pprSlice :: Slice -> SDoc -pprSlice slice = withLessDetail $ pprCoreBindings [ NonRec v e | (v,e) <- slice ] +pprSlice slice = + withLessDetail $ pprCoreBindings [ NonRec v e | (v,e) <- slice ] -- | Pretty-print two slices, after removing variables occurring in both pprSliceDifference :: Slice -> Slice -> SDoc @@ -96,7 +101,7 @@ 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 (last slice1), fst (last slice2))) S.empty + = step (S.singleton (fst (head slice1), fst (head slice2))) S.empty where step :: VarPairSet -> VarPairSet -> Bool step wanted done @@ -111,14 +116,12 @@ equate :: Var -> Var -> MaybeT (State VarPairSet) () equate x y - | it - , Just e1 <- lookup x slice1 + | Just e1 <- lookup x slice1 , Just x' <- essentiallyVar e1 - = equated x' y - | it - , Just e2 <- lookup y slice2 + = lift $ modify (S.insert (x',y)) + | Just e2 <- lookup y slice2 , Just y' <- essentiallyVar e2 - = equated x y' + = lift $ modify (S.insert (x,y')) | Just e1 <- lookup x slice1 , Just e2 <- lookup y slice2 = go (mkRnEnv2 emptyInScopeSet) e1 e2 @@ -129,11 +132,11 @@ equated x y = lift $ modify (S.insert (x,y)) essentiallyVar :: CoreExpr -> Maybe Var - essentiallyVar (App e a) | isTyCoArg a = essentiallyVar e - essentiallyVar (Lam v e) | isTyCoVar v = essentiallyVar e - essentiallyVar (Cast e _) = essentiallyVar e - essentiallyVar (Var v) = Just v - essentiallyVar _ = Nothing + 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 () diff --git a/src/Test/Inspection/Plugin.hs b/src/Test/Inspection/Plugin.hs --- a/src/Test/Inspection/Plugin.hs +++ b/src/Test/Inspection/Plugin.hs @@ -25,6 +25,7 @@ -- | 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 @@ -34,7 +35,7 @@ #endif } -data UponFailure = AbortCompilation | KeepGoing deriving Eq +data UponFailure = AbortCompilation | KeepGoingO0 | KeepGoing deriving Eq data ReportingMode = Verbose | Quiet deriving Eq @@ -44,12 +45,12 @@ install args passes = return $ passes ++ [pass] where pass = CoreDoPluginPass "Test.Inspection.Plugin" (proofPass upon_failure report) - upon_failure | "keep-going" `elem` args = KeepGoing - | otherwise = AbortCompilation + 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 @@ -83,6 +84,7 @@ 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 @@ -109,19 +111,29 @@ PrintAndAbort -> do category <- case (res, expectFail obl) of -- Property holds - (Nothing, False) -> do + (ResSuccess, False) -> do unless (report == Quiet) $ putMsgS $ prettyObligation (mg_module guts) obl expSuccess return ExpSuccess - (Nothing, True) -> do + (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 - (Just reportDoc, False) -> do + (ResFailure reportDoc, False) -> do putMsgS $ prettyObligation (mg_module guts) obl unexpFailure putMsg $ reportDoc return UnexpFailure - (Just _, True) -> do + (ResFailure _, True) -> do unless (report == Quiet) $ putMsgS $ prettyObligation (mg_module guts) obl expFailure return ExpFailure @@ -129,9 +141,12 @@ StoreAt name -> do dflags <- getDynFlags let result = case res of - Nothing -> Success $ showSDoc dflags $ + ResSuccess -> Success $ showSDoc dflags $ text (prettyObligation (mg_module guts) obl expSuccess) - Just reportMsg -> Failure $ showSDoc dflags $ + 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) @@ -143,7 +158,10 @@ expFailure = "failed expectedly." -type CheckResult = Maybe SDoc +data CheckResult + = ResSuccess + | ResSuccessWithMessage SDoc + | ResFailure SDoc lookupNameInGuts :: ModGuts -> Name -> Maybe (Var, CoreExpr) lookupNameInGuts guts n = listToMaybe @@ -169,30 +187,30 @@ let p2 = lookupNameInGuts guts n2 if | n1 == n2 - -> return Nothing + -> pure ResSuccess -- Ok if one points to another | Just (_, Var other) <- p1, getName other == n2 - -> return Nothing + -> pure ResSuccess | Just (_, Var other) <- p2, getName other == n1 - -> return Nothing + -> 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 return Nothing + then pure ResSuccess -- Not ok if the expression differ - else pure . Just $ pprSliceDifference slice1 slice2 + else pure . ResFailure $ pprSliceDifference slice1 slice2 -- Not ok if both names are bound externally | Nothing <- p1 , Nothing <- p2 - -> pure . Just $ ppr n1 <+> text " and " <+> ppr n2 <+> + -> pure . ResFailure $ ppr n1 <+> text " and " <+> ppr n2 <+> text "are different external names" | Nothing <- p1 - -> pure . Just $ ppr n1 <+> text "is an external name" + -> pure . ResFailure $ ppr n1 <+> text "is an external name" | Nothing <- p2 - -> pure . Just $ ppr n2 <+> text "is an external name" + -> pure . ResFailure $ ppr n2 <+> text "is an external name" where binds = flattenBinds (mg_binds guts) @@ -200,41 +218,49 @@ n <- fromTHName thn ns <- mapM fromTHName thns case lookupNameInGuts guts n of - Nothing -> pure . Just $ ppr n <+> text "is not a local name" + Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case freeOfTerm (slice binds v) ns of - Just _ -> pure . Just $ pprSlice (slice binds v) - Nothing -> pure Nothing + 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 . Just $ ppr n <+> text "is not a local name" + Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case freeOfType (slice binds v) ts of - Just _ -> pure . Just $ pprSlice (slice binds v) - Nothing -> pure Nothing + 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 . Just $ ppr n <+> text "is not a local name" + Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotAllocate (slice binds v) of - Just (v',e') -> pure . Just $ nest 4 (ppr v' <+> text "=" <+> ppr e') - Nothing -> pure Nothing + 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 . Just $ ppr n <+> text "is not a local name" + Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotContainTypeClasses (slice binds v) ts of - Just (v',e') -> pure . Just $ nest 4 (ppr v' <+> text "=" <+> ppr e') - Nothing -> pure Nothing + 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 @@ -264,7 +290,8 @@ proofPass :: UponFailure -> ReportingMode -> ModGuts -> CoreM ModGuts proofPass upon_failure report guts = do dflags <- getDynFlags - when (optLevel dflags < 1) $ + 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 @@ -286,12 +313,12 @@ if q ExpSuccess + q ExpFailure + q StoredResult == n then unless (report == Quiet) $ putMsg $ text "inspection testing successful" $$ summary_message - else case upon_failure of - AbortCompilation -> do - errorMsg $ text "inspection testing unsuccessful" $$ summary_message - liftIO $ exitFailure -- kill the compiler. Is there a nicer way? - KeepGoing -> do - warnMsg $ text "inspection testing unsuccessful" $$ 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''