├── tests ├── GoldFiles │ ├── .gitignore │ ├── T03.hs.golden │ ├── T04.hs.golden │ ├── T10.hs.golden │ ├── T15.hs.golden │ ├── T20.hs.golden │ ├── T23.hs.golden │ ├── T24.hs.golden │ ├── T25.hs.golden │ ├── T28.hs.golden │ ├── T30.hs.golden │ ├── T34.hs.golden │ ├── T40.hs.golden │ ├── T45.hs.golden │ ├── T09.hs.golden │ ├── T48.hs.golden │ ├── T26.hs.golden │ ├── T29.hs.golden │ ├── T02.hs.golden │ ├── T05.hs.golden │ ├── T50.hs.golden │ ├── T06.hs.golden │ ├── T07.hs.golden │ ├── T08.hs.golden │ ├── T11.hs.golden │ ├── T14.hs.golden │ ├── T22.hs.golden │ ├── T32.hs.golden │ ├── T33.hs.golden │ ├── T35.hs.golden │ ├── T37.hs.golden │ ├── T39.hs.golden │ ├── T12.hs.golden │ ├── T38.hs.golden │ ├── T41.hs.golden │ ├── T00.hs.golden │ ├── T13.hs.golden │ ├── T36.hs.golden │ ├── T44.hs.golden │ ├── T01.hs.golden │ ├── T42.hs.golden │ ├── T47.hs.golden │ ├── T16.hs.golden │ ├── T17.hs.golden │ ├── T19.hs.golden │ ├── T46.hs.golden │ ├── T49.hs.golden │ ├── T31.hs.golden │ ├── T43.hs.golden │ ├── T27.hs.golden │ ├── T21.hs.golden │ └── T18.hs.golden ├── T48.hs ├── T49.hs ├── T47.hs ├── T25.hs ├── T26.hs ├── T07.hs ├── T34.hs ├── T35.hs ├── T03.hs ├── T04.hs ├── T06.hs ├── T22.hs ├── T02.hs ├── T09.hs ├── T28.hs ├── T39.hs ├── T21.hs ├── T05.hs ├── T12.hs ├── T29.hs ├── T10.hs ├── T20.hs ├── T23.hs ├── T27.hs ├── T40.hs ├── T14.hs ├── T15.hs ├── T16.hs ├── T18.hs ├── T24.hs ├── T37.hs ├── T11.hs ├── T41.hs ├── T42.hs ├── T13.hs ├── T17.hs ├── T00.hs ├── T32.hs ├── T38.hs ├── T08.hs ├── T31.hs ├── T50.hs ├── T30.hs ├── T36.hs ├── T19.hs ├── T01.hs ├── T33.hs ├── T43.hs ├── T44.hs ├── T45.hs ├── T46.hs └── Run.hs ├── Setup.hs ├── COPYRIGHT ├── .ghci ├── .gitignore ├── INSTALL ├── .github └── workflows │ ├── hlint.yml │ └── haskell-ci.yml ├── Data └── SBV │ ├── Plugin │ ├── Examples │ │ ├── Proved.hs │ │ ├── Maximum.hs │ │ ├── MergeSort.hs │ │ ├── BitTricks.hs │ │ └── MicroController.hs │ ├── Data.hs │ ├── Plugin.hs │ ├── Common.hs │ ├── Env.hs │ └── Analyze.hs │ └── Plugin.hs ├── LICENSE ├── Makefile ├── sbvPlugin.cabal ├── README.md └── CHANGES.md /tests/GoldFiles/.gitignore: -------------------------------------------------------------------------------- 1 | *.current 2 | -------------------------------------------------------------------------------- /tests/T48.hs: -------------------------------------------------------------------------------- 1 | ../Data/SBV/Plugin/Examples/MergeSort.hs -------------------------------------------------------------------------------- /tests/T49.hs: -------------------------------------------------------------------------------- 1 | ../Data/SBV/Plugin/Examples/BitTricks.hs -------------------------------------------------------------------------------- /tests/T47.hs: -------------------------------------------------------------------------------- 1 | ../Data/SBV/Plugin/Examples/MicroController.hs -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tests/GoldFiles/T03.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T03.hs:10:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T04.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T04.hs:10:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T10.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T10.hs:12:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T15.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T15.hs:11:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T20.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | [SBV] tests/T20.hs:10:1 Skipping "f": Don't want to prove this now. 3 | -------------------------------------------------------------------------------- /tests/GoldFiles/T23.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T23.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T24.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T24.hs:10:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T25.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T25.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T28.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T28.hs:13:1 Proving "g", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T30.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T30.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T34.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T34.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T40.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T40.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T45.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T45.hs:22:1-7 Proving "filtLen", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T09.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T09.hs:10:1 QuickChecking "f", using Z3. 4 | +++ OK, passed 100 tests. 5 | -------------------------------------------------------------------------------- /tests/GoldFiles/T48.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T48.hs:110:1-16 Proving "mergeSortCorrect", using Z3. 4 | [Z3] Q.E.D. 5 | -------------------------------------------------------------------------------- /tests/T25.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T25 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Bool 9 | f = True 10 | -------------------------------------------------------------------------------- /tests/T26.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T26 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Bool 9 | f = False 10 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2024, Levent Erkok (erkokl@gmail.com) 2 | All rights reserved. 3 | 4 | The sbvPlugin is distributed with the BSD3 license. See the LICENSE file 5 | for details. 6 | -------------------------------------------------------------------------------- /tests/T07.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T07 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Double -> Bool 9 | f x = x == x 10 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall 2 | :set -Werror 3 | :set -fwarn-unused-binds 4 | :set -fwarn-unused-imports 5 | :set -fhide-source-paths 6 | :set -i./Data -i./tests 7 | :set -package ghc 8 | :load Data/SBV/Plugin.hs 9 | -------------------------------------------------------------------------------- /tests/T34.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T34 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Bool 9 | f x y = (x, y) == (x, y) 10 | -------------------------------------------------------------------------------- /tests/T35.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T35 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Bool 9 | f x y = (x, y) == (y, x) 10 | -------------------------------------------------------------------------------- /tests/GoldFiles/T26.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T26.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable 5 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 6 | -------------------------------------------------------------------------------- /tests/GoldFiles/T29.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T29.hs:13:1 Proving "g", using Z3. 4 | [Z3] Falsifiable 5 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 6 | -------------------------------------------------------------------------------- /tests/T03.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T03 where 4 | 5 | import Data.Word 6 | import Data.SBV.Plugin 7 | 8 | {-# ANN f theorem #-} 9 | f :: Word8 -> Bool 10 | f x = x >= x 11 | -------------------------------------------------------------------------------- /tests/T04.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T04 where 4 | 5 | import Data.Word 6 | import Data.SBV.Plugin 7 | 8 | {-# ANN f theorem #-} 9 | f :: Word8 -> Bool 10 | f x = x == x 11 | -------------------------------------------------------------------------------- /tests/GoldFiles/T02.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T02.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = 1 :: Integer 6 | y = 0 :: Integer 7 | -------------------------------------------------------------------------------- /tests/T06.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T06 where 4 | 5 | import Data.Int 6 | import Data.SBV.Plugin 7 | 8 | {-# ANN f theorem #-} 9 | f :: Int8 -> Bool 10 | f x = abs x >= 0 11 | -------------------------------------------------------------------------------- /tests/GoldFiles/T05.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T05.hs:9:1 Proving "f", using CVC4. 4 | [CVC4] Falsifiable. Counter-example: 5 | x = 0 :: Integer 6 | y = -1 :: Integer 7 | -------------------------------------------------------------------------------- /tests/T22.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T22 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | f :: Int -> Bool 8 | f x = x == 0 9 | 10 | {-# ANN g theorem #-} 11 | g :: Int -> Bool 12 | g = f 13 | -------------------------------------------------------------------------------- /tests/T02.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T02 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [IgnoreFailure]} #-} 8 | f :: Integer -> Integer -> Bool 9 | f x y = x == y 10 | -------------------------------------------------------------------------------- /tests/T09.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T09 where 4 | 5 | import Data.Word 6 | import Data.SBV.Plugin 7 | 8 | {-# ANN f theorem {options = [QuickCheck]} #-} 9 | f :: Word32 -> Bool 10 | f x = x == x 11 | -------------------------------------------------------------------------------- /tests/T28.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T28 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | f :: Int -> Bool 8 | f 0 = True 9 | f x = f x 10 | 11 | {-# ANN g theorem #-} 12 | g :: Bool 13 | g = f 0 14 | -------------------------------------------------------------------------------- /tests/T39.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T39 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [Names ["p"]] } #-} 8 | f :: (Int, Int) -> Bool 9 | f (a, b) = (b, a) == (a, b) 10 | -------------------------------------------------------------------------------- /tests/T21.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T21 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options=[Verbose, ListSize 5]} #-} 8 | f :: Char -> String -> Bool 9 | f c s = c == c && s == s 10 | -------------------------------------------------------------------------------- /tests/GoldFiles/T50.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T50.hs:8:1-18 Proving "integerAssociative", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T50.hs:11:1-6 Proving "isTrue", using Z3. 7 | [Z3] Q.E.D. 8 | -------------------------------------------------------------------------------- /tests/T05.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T05 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [IgnoreFailure, CVC4]} #-} 8 | f :: Integer -> Integer -> Bool 9 | f x y = x + y >= x - y 10 | -------------------------------------------------------------------------------- /tests/GoldFiles/T06.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T06.hs:10:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = -128 :: Int8 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/GoldFiles/T07.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T07.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = NaN :: Double 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/GoldFiles/T08.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T08.hs:14:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = 0.0 :: Double 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/GoldFiles/T11.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T11.hs:15:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = 11 :: Integer 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/GoldFiles/T14.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T14.hs:10:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = -1.0 :: Real 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/GoldFiles/T22.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T22.hs:12:1 Proving "g", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | s0 = -1 :: Int64 6 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 7 | -------------------------------------------------------------------------------- /tests/T12.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T12 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Integer -> Bool -> Bool 9 | f i b = case i of 10 | 1 -> True 11 | _ -> b 12 | -------------------------------------------------------------------------------- /tests/T29.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T29 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | f :: Bool -> Bool 8 | f True = False 9 | f False = f False 10 | 11 | {-# ANN g theorem #-} 12 | g :: Bool 13 | g = f True 14 | -------------------------------------------------------------------------------- /tests/T10.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T10 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | g :: Integer -> Integer 8 | g x = x * 2 + 12 9 | 10 | {-# ANN f theorem #-} 11 | f :: Integer -> Bool 12 | f x = g x < g (x+1) 13 | -------------------------------------------------------------------------------- /tests/GoldFiles/T32.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T32.hs:11:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T32.hs:15:1 Proving "g", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | x = 64 :: Word8 9 | -------------------------------------------------------------------------------- /tests/GoldFiles/T33.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T33.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = 0 :: Int64 6 | 7 | [SBV] tests/T33.hs:15:1 Proving "g", using Z3. 8 | [Z3] Q.E.D. 9 | -------------------------------------------------------------------------------- /tests/T20.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T20 where 4 | 5 | import Data.Word 6 | import Data.SBV.Plugin 7 | 8 | {-# ANN f theorem {options = [Skip "Don't want to prove this now."]} #-} 9 | f :: Word8 -> Bool 10 | f x = x >= x 11 | -------------------------------------------------------------------------------- /tests/T23.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T23 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Bool 9 | f x y = lhs == rhs 10 | where lhs = (x-y) * (x+y) 11 | rhs = x*x - y*y 12 | -------------------------------------------------------------------------------- /tests/T27.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T27 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN g theorem {options=[Verbose]}#-} 8 | g :: Bool 9 | g = let x = 3 10 | y = 2 11 | z = x - y 12 | in z == 1 13 | -------------------------------------------------------------------------------- /tests/T40.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T40 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Bool 9 | f = [] == ([] :: [Int]) 10 | 11 | {-# ANN module ("HLint: ignore Use null" :: String) #-} 12 | -------------------------------------------------------------------------------- /tests/T14.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T14 where 4 | 5 | import Data.SBV.Plugin 6 | import Data.Ratio 7 | 8 | {-# ANN f theorem {options = [Names ["x"]]} #-} 9 | f :: Rational -> Bool 10 | f 0 = True 11 | f x = 1 / (1 / x) /= x 12 | -------------------------------------------------------------------------------- /tests/T15.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T15 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | newtype Age = Age Int deriving Eq 8 | 9 | {-# ANN f theorem {options = [Names ["age"]]} #-} 10 | f :: Age -> Bool 11 | f (Age i) = i == i 12 | -------------------------------------------------------------------------------- /tests/GoldFiles/T35.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T35.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = -1 :: Int64 6 | y = 0 :: Int64 7 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 8 | -------------------------------------------------------------------------------- /tests/T16.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T16 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | newtype Age = Age Int deriving Eq 8 | 9 | {-# ANN f theorem {options = [Names ["age"]]} #-} 10 | f :: Age -> Bool 11 | f (Age i) = i == i+1 12 | -------------------------------------------------------------------------------- /tests/GoldFiles/T37.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T37.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | a = 2 :: Int64 6 | b = 2.3 :: Double 7 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 8 | -------------------------------------------------------------------------------- /tests/GoldFiles/T39.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T39.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | p_1 = -1 :: Int64 6 | p_2 = 0 :: Int64 7 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 8 | -------------------------------------------------------------------------------- /tests/GoldFiles/T12.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T12.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | i = 2 :: Integer 6 | b = False :: Bool 7 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 8 | -------------------------------------------------------------------------------- /tests/T18.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T18 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | newtype Age = Age Int deriving Eq 8 | 9 | {-# ANN f theorem {options = [Verbose]} #-} 10 | f :: Age -> Age -> Bool 11 | f a@(Age i) b@(Age j) = a == b 12 | -------------------------------------------------------------------------------- /tests/GoldFiles/T38.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T38.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | a = 1 :: Int64 6 | b = 2 :: Int64 7 | c = 4 :: Int64 8 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 9 | -------------------------------------------------------------------------------- /tests/GoldFiles/T41.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T41.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T41.hs:13:1 Proving "g", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | x = -1 :: Int64 9 | y = 0 :: Int64 10 | -------------------------------------------------------------------------------- /tests/GoldFiles/T00.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T00.hs:12:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T00.hs:16:1 Proving "g", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | _x = 0 :: Int8 9 | _y = False :: Bool 10 | -------------------------------------------------------------------------------- /tests/T24.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T24 where 4 | 5 | import Data.SBV.Plugin 6 | import Data.Int 7 | 8 | {-# ANN f theorem #-} 9 | f :: Int8 -> Int8 -> Bool 10 | f x 0 = True 11 | f x y = x == q * y + r 12 | where q = x `quot` y 13 | r = x `rem` y 14 | -------------------------------------------------------------------------------- /tests/T37.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T37 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Double -> Bool 9 | f a b = case (a, b) of 10 | (2, c) -> c /= 2.3 11 | (_, 3) -> a == a 12 | _ -> True 13 | -------------------------------------------------------------------------------- /tests/GoldFiles/T13.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T13.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | i = 2 :: Integer 6 | d = -5.0e-324 :: Double 7 | b = False :: Bool 8 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 9 | -------------------------------------------------------------------------------- /tests/GoldFiles/T36.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T36.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T36.hs:14:1 Proving "g", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | a = 64 :: Int64 9 | b = -65 :: Int64 10 | c = -65 :: Int64 11 | -------------------------------------------------------------------------------- /tests/T11.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T11 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | h :: Integer -> Integer 8 | h x = x - 1 9 | 10 | g :: Integer -> Integer 11 | g x = if x < 12 then x+1 else h x 12 | 13 | {-# ANN f theorem #-} 14 | f :: Integer -> Bool 15 | f x = g x < g (x+1) 16 | -------------------------------------------------------------------------------- /tests/GoldFiles/T44.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T44.hs:12:1 Proving "t", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T44.hs:20:1 Proving "r", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | b = False :: Bool 9 | x = 0 :: Integer 10 | y = 1 :: Integer 11 | -------------------------------------------------------------------------------- /tests/T41.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T41 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Bool 9 | f x y = [x, y, x] == [x, y, x] 10 | 11 | {-# ANN g theorem {options = [IgnoreFailure]} #-} 12 | g :: Int -> Int -> Bool 13 | g x y = [x, y] == [y, x] 14 | -------------------------------------------------------------------------------- /tests/T42.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T42 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [ListSize 5]} #-} 8 | f :: [Int] -> Bool 9 | f xs = s xs /= 10 10 | where s [] = 0 11 | s (x:xs) = x + s xs 12 | 13 | {-# ANN f ("HLint: ignore Use foldr" :: String) #-} 14 | -------------------------------------------------------------------------------- /tests/T13.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T13 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Integer -> Double -> Bool -> Bool 9 | f i d b = case i of 10 | 1 -> True 11 | _ -> case d of 12 | 3.5 -> True 13 | _ -> (d /= d) || b 14 | -------------------------------------------------------------------------------- /tests/T17.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T17 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN g sbv {options = [Uninterpret]} #-} 8 | g :: Int -> Int 9 | g _x = 0 10 | {-# NOINLINE g #-} -- Avoid GHC from inlinining g first. 11 | 12 | {-# ANN f theorem #-} 13 | f :: Int -> Bool 14 | f x = g x == g (x+1) 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | dist 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .virtualenv 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | .*~ 19 | .*.swp 20 | .ghc.environment.x86_64-darwin-8.6.5 21 | cabal.project.local 22 | dist-newstyle/ 23 | cabal.project.local~* 24 | -------------------------------------------------------------------------------- /tests/GoldFiles/T01.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T01.hs:14:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = -3.733057721622923e-301 :: Double 6 | y = 3.733054162050547e-301 :: Double 7 | z = 3.5580793974836793e-307 :: Double 8 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 9 | -------------------------------------------------------------------------------- /tests/T00.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T00 where 4 | 5 | import Data.Word 6 | import Data.Int 7 | 8 | import Data.SBV.Plugin 9 | 10 | {-# ANN f theorem #-} 11 | f :: Word8 -> Bool -> Bool 12 | f _ _ = True 13 | 14 | {-# ANN g theorem {options = [IgnoreFailure]} #-} 15 | g :: Int8 -> Bool -> Bool 16 | g _x _y = False 17 | -------------------------------------------------------------------------------- /tests/GoldFiles/T42.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T42.hs:9:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | xs_1 = 10 :: Int64 6 | xs_2 = 0 :: Int64 7 | xs_3 = 0 :: Int64 8 | xs_4 = 0 :: Int64 9 | xs_5 = 0 :: Int64 10 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 11 | -------------------------------------------------------------------------------- /tests/T32.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T32 where 4 | 5 | import Data.SBV.Plugin 6 | import Data.Word 7 | import Data.Bits 8 | 9 | {-# ANN f theorem #-} 10 | f :: Word8 -> Bool 11 | f x = x `shiftL` 2 == x * 4 12 | 13 | {-# ANN g theorem {options = [IgnoreFailure]} #-} 14 | g :: Word8 -> Bool 15 | g x = x `shiftL` 2 == x * 2 16 | -------------------------------------------------------------------------------- /tests/GoldFiles/T47.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T47.hs:93:1-8 Proving "checkBad", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | range = 200 :: Int64 6 | manual = False :: Bool 7 | timeSince = 9 :: Int64 8 | 9 | [SBV] tests/T47.hs:115:1-9 Proving "checkGood", using Z3. 10 | [Z3] Q.E.D. 11 | -------------------------------------------------------------------------------- /tests/T38.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T36 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Int -> Bool 9 | f a b c = case arrange (a, (b, c)) of 10 | ((1, 2), (1, 4), 4) -> False 11 | ((d, e), (f, g), h) -> True 12 | where arrange (x, (y, z)) = ((x, y), (x, z), z) 13 | -------------------------------------------------------------------------------- /tests/T08.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T08 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | bad :: Double -> Bool 8 | bad x = (x /= x) -- avoid NaN 9 | || (x == (1/0)) -- avoid +Inf 10 | || (x == -(1/0)) -- avoid -Inf 11 | 12 | {-# ANN f theorem #-} 13 | f :: Double -> Bool 14 | f x 15 | | bad x = True 16 | | True = x == 2.321 17 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | The sbvPlugin can be installed simply by issuing cabal install: 2 | 3 | cabal install sbvPlugin 4 | 5 | This will also install the SBV library if you do not already have it. 6 | You should also install an SMT solver, preferably the default solver 7 | used by SBV; i.e., Z3 from Microsoft: . 8 | Please make sure that the "z3" executable is in your path. 9 | -------------------------------------------------------------------------------- /tests/T31.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T31 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [IgnoreFailure]} #-} 8 | f :: Int -> Int 9 | f x = x + 1 10 | 11 | {-# ANN g theorem {options = [IgnoreFailure]} #-} 12 | g :: Char 13 | g = 'a' 14 | 15 | {-# ANN h theorem {options = [IgnoreFailure]} #-} 16 | h :: Double 17 | h = 0 18 | -------------------------------------------------------------------------------- /tests/T50.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T50 where 4 | 5 | import Data.SBV.Plugin.Data 6 | 7 | integerAssociative :: Proved (Integer -> Integer -> Integer -> Bool) 8 | integerAssociative x y z = ((x + y) + z) == (x + (y + z)) 9 | 10 | isTrue :: Proved Bool 11 | isTrue = True || False 12 | 13 | {-# ANN module ("HLint: ignore Evaluate" :: String) #-} 14 | -------------------------------------------------------------------------------- /tests/GoldFiles/T16.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T16.hs:11:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | ds_dbJo = 0 :: Int64 6 | age = Age_0 :: Age 7 | [SBV] Counter-example might be bogus due to uninterpreted constant: 8 | [] ds_dbJo :: Int 9 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 10 | -------------------------------------------------------------------------------- /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: lint 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - master 7 | - 'releases/*' 8 | 9 | jobs: 10 | hlint: 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - name: 'Set up HLint' 16 | uses: rwe/actions-hlint-setup@v1 17 | 18 | - name: 'Run HLint' 19 | uses: rwe/actions-hlint-run@v2 20 | -------------------------------------------------------------------------------- /tests/GoldFiles/T17.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T17.hs:14:1 Proving "f", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | x = 0 :: Int64 6 | 7 | g :: Int64 -> Int64 8 | g 1 = 0 9 | g _ = -1 10 | [SBV] Counter-example might be bogus due to uninterpreted constant: 11 | [tests/T17.hs:9:1] g :: Int -> Int 12 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 13 | -------------------------------------------------------------------------------- /tests/T30.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T30 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Bool 9 | f x 10 | | x < 0 = True 11 | | x > 10 = True 12 | | True = foo x 10 == x*(x+1) `div` 2 13 | where -- Note the use of counter to stop symbolic recursion! 14 | foo :: Int -> Int -> Int 15 | foo _ 0 = 0 16 | foo 0 _ = 0 17 | foo n c = n + foo (n-1) (c-1) 18 | -------------------------------------------------------------------------------- /tests/T36.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T36 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem #-} 8 | f :: Int -> Int -> Int -> Bool 9 | f a b c = rot (rot (rot (a, b, c))) == (a, b, c) 10 | where rot (x, y, z) = (y, z, x) 11 | 12 | {-# ANN g theorem {options = [IgnoreFailure]} #-} 13 | g :: Int -> Int -> Int -> Bool 14 | g a b c = rot (rot (a, 3, b, c)) == (a, b, c, 3::Int) 15 | where rot (x, y, z, w) = (y, z, w, x) 16 | -------------------------------------------------------------------------------- /tests/T19.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T19 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options=[ListSize 5]} #-} 8 | f :: String -> Bool 9 | f s = rev (rev s) == s 10 | where rev [a, b, c, d, e] = [e, d, c, b, a] 11 | rev xs = 'a':xs 12 | 13 | {-# ANN g theorem {options=[ListSize 6, IgnoreFailure]} #-} 14 | g :: String -> Bool 15 | g s = f s 16 | 17 | {-# ANN g ("HLint: ignore Eta reduce" :: String) #-} 18 | -------------------------------------------------------------------------------- /tests/T01.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T01 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | bad :: Double -> Bool 8 | bad x = (x /= x) -- avoid NaN 9 | || (x == (1/0)) -- avoid +Inf 10 | || (x == -(1/0)) -- avoid -Inf 11 | 12 | {-# ANN f theorem #-} 13 | f :: Double -> Double -> Double -> Bool 14 | f x y z 15 | | bad (x + (y + z)) || bad ((x + y) + z) = True 16 | | True = x + (y + z) == (x + y) + z 17 | -------------------------------------------------------------------------------- /tests/GoldFiles/T19.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T19.hs:9:1 Proving "f", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T19.hs:15:1 Proving "g", using Z3. 7 | [Z3] Falsifiable. Counter-example: 8 | s_1 = Char_0 :: Char 9 | s_2 = Char_0 :: Char 10 | s_3 = Char_0 :: Char 11 | s_4 = Char_0 :: Char 12 | s_5 = Char_0 :: Char 13 | s_6 = Char_0 :: Char 14 | [SBV] Counter-example might be bogus due to uninterpreted constants: 15 | [] C# :: Char# %1 -> Char 16 | -------------------------------------------------------------------------------- /tests/T33.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T33 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | {-# ANN f theorem {options = [IgnoreFailure]} #-} 8 | f :: Int -> Bool 9 | f x = foo x == x 10 | where -- foo :: Int -> Int. -- Type commented out on purpose to test the polymorphism here. 11 | foo a = a+1 12 | 13 | {-# ANN g theorem #-} 14 | g :: Int -> Bool 15 | g x = foo x == x 16 | where -- foo :: Int -> Int. -- Type commented out on purpose to test the polymorphism here. 17 | foo a = a 18 | -------------------------------------------------------------------------------- /tests/T43.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T43 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | s :: [Int] -> Int 8 | s [] = 0 9 | s (x:xs) = x + s xs 10 | 11 | {-# ANN t theorem #-} 12 | t :: Int -> Bool 13 | t x = 3 * x == s lst 14 | where lst | x == 0 = [x, x, x] 15 | | True = [x, x, x] 16 | 17 | {-# ANN r theorem {options = [IgnoreFailure]} #-} 18 | r :: Int -> Bool 19 | r x = 3 * x == s lst 20 | where lst | x == 0 = [x, x, x] 21 | | True = [x, x, x, x] 22 | 23 | {-# ANN s ("HLint: ignore Use foldr" :: String) #-} 24 | -------------------------------------------------------------------------------- /tests/T44.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T43 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | -- Prove both addition and multiplication are 8 | -- commutative over integers; with a higher-order 9 | -- case! 10 | {-# ANN t theorem #-} 11 | t :: Bool -> Integer -> Integer -> Bool 12 | t b x y = f x y == f y x 13 | where f | b = (+) 14 | | True = (*) 15 | 16 | -- Simiar, except we put in subtraction in one case 17 | -- to cause failure! 18 | {-# ANN r theorem {options = [IgnoreFailure]} #-} 19 | r :: Bool -> Integer -> Integer -> Bool 20 | r b x y = f x y == f y x 21 | where f | b = (+) 22 | | True = (-) 23 | -------------------------------------------------------------------------------- /tests/GoldFiles/T46.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T46.hs:22:1-10 Proving "filtLenBad", using Z3. 4 | [Z3] Falsifiable. Counter-example: 5 | xs_1 = 1896580642610626484 :: Int64 6 | xs_2 = -1896580642610626485 :: Int64 7 | xs_3 = 2122839034131759177 :: Int64 8 | xs_4 = 1896667638314056885 :: Int64 9 | xs_5 = -3347824179180231500 :: Int64 10 | 11 | f :: Int64 -> Bool 12 | f (-3347824179180231500) = True 13 | f 1896667638314056885 = True 14 | f 1896580642610626484 = True 15 | f _ = False 16 | 17 | [SBV] tests/T46.hs:26:1-11 Proving "filtLenGood", using Z3. 18 | [Z3] Q.E.D. 19 | -------------------------------------------------------------------------------- /tests/T45.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T45 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | type Valid = (Int, Bool) 8 | 9 | markValid :: (Int -> Bool) -> [Int] -> [Valid] 10 | markValid f xs = [(x, f x) | x <- xs] 11 | 12 | foldValid :: (Int -> Int -> Int) -> Int -> [Valid] -> Int 13 | foldValid _ b [] = b 14 | foldValid f b ((_, False):rest) = foldValid f b rest 15 | foldValid f b ((x, True) :rest) = f x (foldValid f b rest) 16 | 17 | len :: [Valid] -> Int 18 | len = foldValid (\_ n -> n+1) 0 19 | 20 | {-# ANN filtLen theorem {options = [ListSize 5]} #-} 21 | filtLen :: [Int] -> Bool 22 | filtLen xs = len (markValid (\x -> x `quot` 2 == 0) xs) <= len (markValid (\_ -> True) xs) 23 | 24 | {-# ANN filtLen ("HLint: ignore Use const") #-} 25 | -------------------------------------------------------------------------------- /tests/GoldFiles/T49.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T49.hs:44:1-14 Proving "fastMinCorrect", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T49.hs:50:1-14 Proving "fastMaxCorrect", using Z3. 7 | [Z3] Q.E.D. 8 | 9 | [SBV] tests/T49.hs:56:1-20 Proving "oppositeSignsCorrect", using Z3. 10 | [Z3] Q.E.D. 11 | 12 | [SBV] tests/T49.hs:62:1-26 Proving "conditionalSetClearCorrect", using Z3. 13 | [Z3] Q.E.D. 14 | 15 | [SBV] tests/T49.hs:69:1-17 Proving "powerOfTwoCorrect", using Z3. 16 | [Z3] Q.E.D. 17 | 18 | [SBV] tests/T49.hs:74:1-18 Proving "maskedMergeCorrect", using Z3. 19 | [Z3] Q.E.D. 20 | 21 | [SBV] tests/T49.hs:80:1-22 Proving "roundPowerOfTwoCorrect", using Z3. 22 | [Z3] Q.E.D. 23 | 24 | [SBV] tests/T49.hs:100:1-10 Proving "zeroInWord", using Z3. 25 | [Z3] Q.E.D. 26 | -------------------------------------------------------------------------------- /tests/GoldFiles/T31.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T31.hs:9:1 Proving "f", using Z3. 4 | 5 | [SBV] tests/T31.hs:9:1 Skipping proof. Non-boolean property declaration: 6 | Found : Int -> Int 7 | Returning: Int 8 | Expected : Bool result 9 | 10 | [SBV] tests/T31.hs:13:1 Proving "g", using Z3. 11 | 12 | [SBV] tests/T31.hs:13:1 Skipping proof. Non-boolean property declaration: 13 | Found : Char 14 | Expected : Bool 15 | 16 | [SBV] tests/T31.hs:17:1 Proving "h", using Z3. 17 | 18 | [SBV] tests/T31.hs:17:1 Skipping proof. Non-boolean property declaration: 19 | Found : Double 20 | Expected : Bool 21 | -------------------------------------------------------------------------------- /tests/GoldFiles/T43.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T43.hs:13:1 Proving "t", using Z3. 4 | [Z3] Q.E.D. 5 | 6 | [SBV] tests/T43.hs:19:1 Proving "r", using Z3. 7 | 8 | [SBV] tests/T43.hs:19:1 Skipping proof. Unsupported case-expression (with-complicated-alternatives-during-merging): 9 | case == @Int $fEqInt x (I# 0#) of { 10 | False -> : @Int x (: @Int x (: @Int x (: @Int x ([] @Int)))); 11 | True -> : @Int x (: @Int x (: @Int x ([] @Int))) 12 | } 13 | While Analyzing: 14 | Alternatives are producing lists of differing sizes: 15 | Length 4: [ :: SInt64, 16 | :: SInt64, 17 | :: SInt64, 18 | :: SInt64] 19 | vs Length 3: [ :: SInt64, :: SInt64, :: SInt64] 20 | -------------------------------------------------------------------------------- /tests/GoldFiles/T27.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T27.hs:9:1 Proving "g", using Z3. 4 | ** Calling: z3 -nw -in -smt2 5 | [GOOD] ; Automatically generated by SBV. Do not edit. 6 | [GOOD] (set-option :print-success true) 7 | [GOOD] (set-option :global-declarations true) 8 | [GOOD] (set-option :smtlib2_compliant true) 9 | [GOOD] (set-option :diagnostic-output-channel "stdout") 10 | [GOOD] (set-option :produce-models true) 11 | [GOOD] (set-logic QF_BV) 12 | [GOOD] ; --- tuples --- 13 | [GOOD] ; --- sums --- 14 | [GOOD] ; --- literal constants --- 15 | [GOOD] ; --- top level inputs --- 16 | [GOOD] ; --- constant tables --- 17 | [GOOD] ; --- non-constant tables --- 18 | [GOOD] ; --- uninterpreted constants --- 19 | [GOOD] ; --- user defined functions --- 20 | [GOOD] ; --- assignments --- 21 | [GOOD] ; --- delayedEqualities --- 22 | [GOOD] ; --- formula --- 23 | [GOOD] (assert false) 24 | [SEND] (check-sat) 25 | [RECV] unsat 26 | *** Solver : Z3 27 | *** Exit code: ExitSuccess 28 | [Z3] Q.E.D. 29 | -------------------------------------------------------------------------------- /tests/T46.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 2 | 3 | module T46 where 4 | 5 | import Data.SBV.Plugin 6 | 7 | type Valid = (Int, Bool) 8 | 9 | markValid :: (Int -> Bool) -> [Int] -> [Valid] 10 | markValid f xs = [(x, f x) | x <- xs] 11 | 12 | foldValid :: (Int -> Int -> Int) -> Int -> [Valid] -> Int 13 | foldValid _ b [] = b 14 | foldValid f b ((_, False):rest) = foldValid f b rest 15 | foldValid f b ((x, True) :rest) = f x (foldValid f b rest) 16 | 17 | len :: [Valid] -> Int 18 | len = foldValid (\_ n -> n+1) 0 19 | 20 | {-# ANN filtLenBad theorem {options = [ListSize 5, IgnoreFailure]} #-} 21 | filtLenBad :: (Int -> Bool) -> [Int] -> Bool 22 | filtLenBad f xs = len (markValid f xs) <= len (markValid (\_ -> False) xs) 23 | 24 | {-# ANN filtLenGood theorem {options = [ListSize 5]} #-} 25 | filtLenGood :: (Int -> Bool) -> [Int] -> Bool 26 | filtLenGood f xs = len (markValid f xs) <= len (markValid (\_ -> True) xs) 27 | 28 | {-# ANN filtLenBad ("HLint: ignore Use const") #-} 29 | {-# ANN filtLenGood ("HLint: ignore Use const") #-} 30 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Examples/Proved.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Examples.Proved 4 | -- Copyright : (c) Nickolas Fotopoulos 5 | -- License : BSD3 6 | -- Maintainer : nickolas.fotopoulos@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- An example of activating sbvPlugin by wrapping types in Proved 10 | -- instead of using an annotation. 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | {-# LANGUAGE CPP #-} 15 | 16 | #ifndef HADDOCK 17 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 18 | #endif 19 | 20 | {-# OPTIONS_GHC -Wall -Werror #-} 21 | 22 | module Data.SBV.Plugin.Examples.Proved where 23 | 24 | import Data.SBV.Plugin 25 | 26 | -- | A top-level binding with its type wrapped in Proved causes sbvPlugin to 27 | -- run a proof on the expression. 28 | integerAssociative :: Proved (Integer -> Integer -> Integer -> Bool) 29 | integerAssociative x y z = ((x + y) + z) == (x + (y + z)) 30 | 31 | -- | Simple booleans can be made theorems too. 32 | isTrue :: Proved Bool 33 | isTrue = True || False 34 | 35 | {-# ANN module ("HLint: ignore Evaluate" :: String) #-} 36 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Examples/Maximum.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Examples.Maximum 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Shows that a naive definition of maximum doing bit-vector arithmetic 10 | -- is incorrect. 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE CPP #-} 14 | 15 | #ifndef HADDOCK 16 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 17 | #endif 18 | 19 | {-# OPTIONS_GHC -Wall -Werror #-} 20 | 21 | module Data.SBV.Plugin.Examples.Maximum where 22 | 23 | import Data.SBV.Plugin 24 | 25 | -- | Compute the maximum of three integers, which 26 | -- is intuitively correct for unbounded values, but 27 | -- not for bounded bit-vectors. 28 | myMax :: Int -> Int -> Int -> Int 29 | myMax x y z | x-y >= 0 && x-z >= 0 = x 30 | | y-x >= 0 && y-z >= 0 = y 31 | | otherwise = z 32 | 33 | -- | Show that this function fails to compute maximum correctly. 34 | -- We have: 35 | -- 36 | -- @ 37 | -- [SBV] a.hs:11:1-7 Proving "correct", using Z3. 38 | -- [Z3] Falsifiable. Counter-example: 39 | -- x = -2816883406898309583 :: Int64 40 | -- y = -2816883406898309583 :: Int64 41 | -- z = 6694719001794338309 :: Int64 42 | -- @ 43 | correct :: Proved (Int -> Int -> Int -> Bool) 44 | correct x y z = m >= x && m >= y && m >= z 45 | where m = myMax x y z 46 | -------------------------------------------------------------------------------- /tests/GoldFiles/T21.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T21.hs:9:1 Proving "f", using Z3. 4 | ** Calling: z3 -nw -in -smt2 5 | [GOOD] ; Automatically generated by SBV. Do not edit. 6 | [GOOD] (set-option :print-success true) 7 | [GOOD] (set-option :global-declarations true) 8 | [GOOD] (set-option :smtlib2_compliant true) 9 | [GOOD] (set-option :diagnostic-output-channel "stdout") 10 | [GOOD] (set-option :produce-models true) 11 | [GOOD] (set-logic ALL) ; has user-defined data-types, using catch-all. 12 | [GOOD] ; --- tuples --- 13 | [GOOD] ; --- sums --- 14 | [GOOD] ; --- ADTs --- 15 | [GOOD] (declare-sort Char 0) ; N.B. Uninterpreted sort. 16 | [GOOD] ; --- literal constants --- 17 | [GOOD] ; --- top level inputs --- 18 | [GOOD] (declare-fun s0 () Char) ; tracks user variable "c" 19 | [GOOD] (declare-fun s1 () Char) ; tracks user variable "s_1" 20 | [GOOD] (declare-fun s2 () Char) ; tracks user variable "s_2" 21 | [GOOD] (declare-fun s3 () Char) ; tracks user variable "s_3" 22 | [GOOD] (declare-fun s4 () Char) ; tracks user variable "s_4" 23 | [GOOD] (declare-fun s5 () Char) ; tracks user variable "s_5" 24 | [GOOD] ; --- constant tables --- 25 | [GOOD] ; --- non-constant tables --- 26 | [GOOD] ; --- uninterpreted constants --- 27 | [GOOD] ; --- user defined functions --- 28 | [GOOD] ; --- assignments --- 29 | [GOOD] ; --- delayedEqualities --- 30 | [GOOD] ; --- formula --- 31 | [GOOD] (assert false) 32 | [SEND] (check-sat) 33 | [RECV] unsat 34 | *** Solver : Z3 35 | *** Exit code: ExitSuccess 36 | [Z3] Q.E.D. 37 | -------------------------------------------------------------------------------- /tests/GoldFiles/T18.hs.golden: -------------------------------------------------------------------------------- 1 | Loaded package environment from test-modified path 2 | 3 | [SBV] tests/T18.hs:11:1 Proving "f", using Z3. 4 | ** Calling: z3 -nw -in -smt2 5 | [GOOD] ; Automatically generated by SBV. Do not edit. 6 | [GOOD] (set-option :print-success true) 7 | [GOOD] (set-option :global-declarations true) 8 | [GOOD] (set-option :smtlib2_compliant true) 9 | [GOOD] (set-option :diagnostic-output-channel "stdout") 10 | [GOOD] (set-option :produce-models true) 11 | [GOOD] (set-logic ALL) ; has user-defined data-types, using catch-all. 12 | [GOOD] ; --- tuples --- 13 | [GOOD] ; --- sums --- 14 | [GOOD] ; --- ADTs --- 15 | [GOOD] (declare-sort Age 0) ; N.B. Uninterpreted sort. 16 | [GOOD] ; --- literal constants --- 17 | [GOOD] ; --- top level inputs --- 18 | [GOOD] (declare-fun s0 () Age) ; tracks user variable "a" 19 | [GOOD] (declare-fun s1 () Age) ; tracks user variable "b" 20 | [GOOD] ; --- constant tables --- 21 | [GOOD] ; --- non-constant tables --- 22 | [GOOD] ; --- uninterpreted constants --- 23 | [GOOD] ; --- user defined functions --- 24 | [GOOD] ; --- assignments --- 25 | [GOOD] (define-fun s2 () Bool (= s0 s1)) 26 | [GOOD] ; --- delayedEqualities --- 27 | [GOOD] ; --- formula --- 28 | [GOOD] (assert (not s2)) 29 | [SEND] (check-sat) 30 | [RECV] sat 31 | [SEND] (get-value (s0)) 32 | [RECV] ((s0 Age!val!0)) 33 | [SEND] (get-value (s1)) 34 | [RECV] ((s1 Age!val!1)) 35 | *** Solver : Z3 36 | *** Exit code: ExitSuccess 37 | [Z3] Falsifiable. Counter-example: 38 | a = Age_0 :: Age 39 | b = Age_1 :: Age 40 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | sbvPlugin: SMT based theorem prover for Haskell 2 | 3 | Copyright (c) 2015-2024, Levent Erkok (erkokl@gmail.com) 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | * Neither the name of the developer (Levent Erkok) nor the 14 | names of its contributors may be used to endorse or promote products 15 | derived from this software without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL LEVENT ERKOK BE LIABLE FOR ANY 21 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 24 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /tests/Run.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -Werror #-} 2 | 3 | module Main(main) where 4 | 5 | import Control.Monad (void) 6 | 7 | import Data.Char (isDigit) 8 | 9 | import Test.Tasty 10 | import Test.Tasty.Golden 11 | 12 | import System.Directory 13 | import System.FilePath 14 | import System.Process 15 | 16 | main :: IO () 17 | main = do tests <- findTests 18 | defaultMain (testGroup "Tests" [unitTests tests]) 19 | where unitTests = testGroup "Unit tests" . map (runTest . takeBaseName) 20 | 21 | findTests :: IO [FilePath] 22 | findTests = do allEntries <- getDirectoryContents "tests" 23 | let testFile f = let b = takeBaseName f 24 | e = takeExtension f 25 | in e == ".hs" && case b of 26 | 'T':xs -> all isDigit xs 27 | _ -> False 28 | return $ filter testFile allEntries 29 | 30 | packages :: [String] 31 | packages = ["-package " ++ p | p <- ps] 32 | where ps = [ "base" 33 | , "containers" 34 | , "mtl" 35 | , "template-haskell" 36 | , "ghc-prim" 37 | ] 38 | 39 | runTest :: String -> TestTree 40 | runTest f = goldenVsFile f gld out act 41 | where (inp, hi, o, gld, out) = fileNames f 42 | act = do void $ system $ unwords $ ["ghc"] ++ packages ++ ["-c", inp, ">", out, "2>&1"] 43 | void $ system $ unwords ["sed", "-i", "''", "'s/^Loaded package environment from.*/Loaded package environment from test-modified path/g'", out] 44 | void $ system $ unwords ["/bin/rm", "-f", hi, o] 45 | 46 | fileNames :: FilePath -> (FilePath, FilePath, FilePath, FilePath, FilePath) 47 | fileNames fp = (inp, hi, o, gld, out) 48 | where f = takeBaseName fp 49 | inp = "tests" f <.> "hs" 50 | hi = "tests" f <.> "hi" 51 | o = "tests" f <.> "o" 52 | gld = "tests/GoldFiles" f <.> "hs.golden" 53 | out = "tests/GoldFiles" f <.> "hs.current" 54 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # (c) Copyright Levent Erkok. All rights reserved. 2 | # 3 | # sbvPlugin is distributed with the BSD3 license. See the LICENSE file in the distribution for details. 4 | SHELL := /usr/bin/env bash 5 | CABAL = cabal 6 | CONFIGOPTS = "-Wall -fhide-source-paths" 7 | 8 | ifeq ($(shell uname -s),Darwin) 9 | TIME = /usr/bin/time caffeinate 10 | else 11 | TIME = /usr/bin/time 12 | endif 13 | 14 | .PHONY: all install test vtest sdist clean docs gold hlint tags ci 15 | 16 | all: install 17 | 18 | install: $(DEPSRCS) Makefile 19 | @fast-tags -R --nomerge . 20 | @$(CABAL) new-configure --disable-library-profiling --enable-tests --ghc-options=$(CONFIGOPTS) 21 | @$(CABAL) new-install --lib --force-reinstalls 22 | 23 | test: 24 | $(TIME) $(CABAL) new-test 25 | @rm -rf tests/GoldFiles/*.current 26 | 27 | vtest: 28 | $(TIME) cabal new-run sbvPluginTests 29 | @rm -rf tests/GoldFiles/*.current 30 | 31 | HADDOCK_OPTS=${CABAL_OPTS} --enable-documentation --ghc-options=-DHADDOCK --haddock-option="--optghc=-DHADDOCK" 32 | 33 | # To upload docs to hackage, first run the below target then run the next target.. 34 | docs: 35 | @cabal haddock ${HADDOCK_OPTS} --haddock-for-hackage 36 | 37 | upload-docs-to-hackage: 38 | cabal upload -d --publish ./dist-newstyle/sbvPlugin-9.12.1-docs.tar.gz 39 | 40 | # use this as follows: make gold TGT=T49 41 | gold: 42 | cabal new-run sbvPluginTests -- -p ${TGT} --accept 43 | 44 | # recreate all golds 45 | allgold: 46 | cabal new-run sbvPluginTests -- --accept 47 | 48 | ghci: 49 | cabal new-repl sbvPlugin 50 | 51 | ghcid: 52 | ghcid --command="cabal new-repl --repl-options=-Wno-unused-packages" 53 | 54 | sdist: install 55 | $(CABAL) new-sdist 56 | 57 | veryclean: clean 58 | 59 | clean: 60 | @rm -rf dist dist-newstyle cabal.project.local* 61 | 62 | release: clean install sdist hlint vtest checkLinks 63 | @echo "*** SBVPlugin is ready for release!" 64 | 65 | hlint: 66 | @rm -f hlintReport.html 67 | @echo "Running HLint.." 68 | @hlint Data tests -i "Use otherwise" -i "Use module export list" 69 | 70 | checkLinks: 71 | @brok --no-cache --only-failures $(DEPSRCS) COPYRIGHT INSTALL LICENSE $(wildcard *.md) 72 | 73 | ci: 74 | haskell-ci github sbvPlugin.cabal --no-tests --no-benchmarks --no-doctest --no-hlint --email-notifications --no-haddock 75 | 76 | tags: 77 | @fast-tags -R --nomerge . 78 | -------------------------------------------------------------------------------- /sbvPlugin.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version : 2.2 2 | Name : sbvPlugin 3 | Version : 9.12.2 4 | Category : Formal methods, Theorem provers, Math, SMT, Symbolic Computation 5 | Synopsis : Formally prove properties of Haskell programs using SBV/SMT 6 | Description : GHC plugin for proving properties over Haskell functions using SMT solvers, based 7 | on the package. 8 | . 9 | See "Data.SBV.Plugin" for a quick example, or the modules under 'Data.SBV.Plugin.Examples' 10 | for more details. 11 | License : BSD-3-Clause 12 | License-file : LICENSE 13 | Stability : Experimental 14 | Author : Levent Erkok 15 | Homepage : http://github.com/LeventErkok/sbvPlugin 16 | Bug-reports : http://github.com/LeventErkok/sbvPlugin/issues 17 | Maintainer : Levent Erkok (erkokl@gmail.com) 18 | Build-Type : Simple 19 | Extra-Source-Files: INSTALL, README.md, COPYRIGHT, CHANGES.md 20 | 21 | Tested-With : GHC==9.12.2 22 | 23 | source-repository head 24 | type: git 25 | location: git://github.com/LeventErkok/sbvPlugin.git 26 | 27 | Library 28 | default-language: Haskell2010 29 | ghc-options : -Wall -fplugin-opt Data.SBV.Plugin:skip 30 | Exposed-modules : Data.SBV.Plugin 31 | , Data.SBV.Plugin.Data 32 | , Data.SBV.Plugin.Examples.BitTricks 33 | , Data.SBV.Plugin.Examples.Maximum 34 | , Data.SBV.Plugin.Examples.MergeSort 35 | , Data.SBV.Plugin.Examples.MicroController 36 | build-depends : base >= 4.19 && < 5 37 | , sbv >= 13.3 38 | , ghc >= 9.12.2 39 | , ghc-prim 40 | , containers 41 | , mtl 42 | , template-haskell 43 | Other-modules : Data.SBV.Plugin.Analyze 44 | , Data.SBV.Plugin.Common 45 | , Data.SBV.Plugin.Env 46 | , Data.SBV.Plugin.Plugin 47 | , Data.SBV.Plugin.Examples.Proved 48 | 49 | Test-Suite sbvPluginTests 50 | type : exitcode-stdio-1.0 51 | default-language: Haskell2010 52 | ghc-options : -Wall 53 | Build-depends : base >= 4.19 && < 5 54 | , sbvPlugin 55 | , tasty 56 | , tasty-golden 57 | , filepath 58 | , process 59 | , directory 60 | Hs-Source-Dirs : tests 61 | main-is : Run.hs 62 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Data.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Data 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Internal data-structures for the sbvPlugin 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE DeriveDataTypeable #-} 13 | 14 | {-# OPTIONS_GHC -Wall -Werror #-} 15 | 16 | module Data.SBV.Plugin.Data where 17 | 18 | import Data.Data (Data) 19 | 20 | -- | Plugin options. Note that we allow picking multiple solvers, which 21 | -- will all be run in parallel. You can pick and choose any number of them, 22 | -- or if you want to run all available solvers, then use the option 'AnySolver'. 23 | -- The default behavior is to error-out on failure, using the default-SMT solver picked by SBV, which is currently Z3. 24 | data SBVOption = IgnoreFailure -- ^ Continue even if proof fails 25 | | Skip String -- ^ Skip the proof. Can be handy for properties that we currently do not want to focus on. 26 | | Verbose -- ^ Produce verbose output, good for debugging 27 | | Debug -- ^ Produce really verbose output, use only when things go really wrong! 28 | | QuickCheck -- ^ Perform quickCheck 29 | | Uninterpret -- ^ Uninterpret this binding for proof purposes 30 | | Names [String] -- ^ Use these names for the arguments; need not be exhaustive 31 | | ListSize Int -- ^ If a list-input is found, use this length. If not specified, we will complain! 32 | | Z3 -- ^ Use Z3 33 | | Yices -- ^ Use Yices 34 | | Boolector -- ^ Use Boolector 35 | | CVC4 -- ^ Use CVC4 36 | | CVC5 -- ^ Use CVC5 37 | | DReal -- ^ Use DReal 38 | | MathSAT -- ^ Use MathSAT 39 | | OpenSMT -- ^ Use OpenSMT 40 | | ABC -- ^ Use ABC 41 | | Bitwuzla -- ^ Use Bitwuzla 42 | | AnySolver -- ^ Run all installed solvers in parallel, and report the result from the first to finish 43 | deriving (Show, Eq, Data) 44 | 45 | -- | The actual annotation. 46 | newtype SBVAnnotation = SBV {options :: [SBVOption]} 47 | deriving (Eq, Data) 48 | 49 | -- | A property annotation, using default options. 50 | sbv :: SBVAnnotation 51 | sbv = SBV {options = []} 52 | 53 | -- | Synonym for sbv really, just looks cooler 54 | theorem :: SBVAnnotation 55 | theorem = sbv 56 | 57 | -- | Importable type as an annotation alternative 58 | type Proved a = a 59 | -------------------------------------------------------------------------------- /Data/SBV/Plugin.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- (The sbvPlugin is hosted at . 10 | -- Comments, bug reports, and patches are always welcome.) 11 | -- 12 | -- == SBVPlugin: A GHC Plugin for SBV, SMT Based Verification 13 | -- 14 | -- is a library for express properties about Haskell programs and 15 | -- automatically proving them using SMT solvers. The SBVPlugin allows 16 | -- simple annotations on Haskell functions to prove them directly during 17 | -- GHC compilation time. 18 | -- 19 | -- === /Example/ 20 | -- > {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 21 | -- > 22 | -- > module Test where 23 | -- > 24 | -- > import Data.SBV.Plugin 25 | -- > 26 | -- > {-# ANN test theorem #-} 27 | -- > test :: Integer -> Integer -> Bool 28 | -- > test x y = x + y >= x - y 29 | -- 30 | -- When compiled via GHC or loaded into GHCi, we get: 31 | -- 32 | -- > [SBV] Test.hs:9:1-4 Proving "test", using Z3. 33 | -- > [Z3] Falsifiable. Counter-example: 34 | -- > x = 0 :: Integer 35 | -- > y = -1 :: Integer 36 | -- > [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 37 | -- 38 | -- Note that the compilation will be aborted, since the theorem doesn't hold. As shown in the hint, GHC 39 | -- can be instructed to continue in that case, using an annotation of the form: 40 | -- 41 | -- > {-# ANN test theorem {options = [IgnoreFailure]} #-} 42 | -- 43 | -- === /Using the plugin from GHCi/ 44 | -- The plugin should work from GHCi with no changes. Note that when run from GHCi, the plugin will 45 | -- behave as if the @IgnoreFailure@ option is given on all annotations, so that failures do not stop 46 | -- the load process. 47 | -- 48 | -- === /Plugin order/ 49 | -- By default, sbvPlugin runs before GHCs optimizer passes. While the order of the run should 50 | -- not matter in general, the simplifier can rearrange the core in various ways that can have 51 | -- an impact on the verification conditions generated by the plugin. As an experiment, you can 52 | -- pass the argument @runLast@ to the plugin to see if it makes any difference, using the following 53 | -- argument to GHC: 54 | -- 55 | -- @ 56 | -- -fplugin-opt Data.SBV.Plugin:runLast 57 | -- @ 58 | -- 59 | -- Please report if you find any crucial differences when the plugin is run first or last, especially 60 | -- if the outputs are different. 61 | --------------------------------------------------------------------------------- 62 | 63 | {-# OPTIONS_GHC -Wall -Werror #-} 64 | 65 | module Data.SBV.Plugin( 66 | -- * Entry point 67 | plugin 68 | -- * Annotations 69 | , SBVAnnotation(..) 70 | , sbv, theorem 71 | -- * Plugin options 72 | , SBVOption(..) 73 | -- * The 'Proved' type 74 | , Proved 75 | ) where 76 | 77 | import Data.SBV.Plugin.Plugin 78 | import Data.SBV.Plugin.Data 79 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## SBVPlugin: SBV Plugin for GHC 2 | 3 | On Hackage: http://hackage.haskell.org/package/sbvPlugin 4 | 5 | ### Example 6 | 7 | ```haskell 8 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 9 | 10 | module Test where 11 | 12 | import Data.SBV.Plugin 13 | 14 | test :: Proved (Integer -> Integer -> Bool) 15 | test x y = x + y >= x - y 16 | ``` 17 | 18 | *Note the GHC option on the very first line. Either add this to your file, or pass `-fplugin=Data.SBV.Plugin` as an 19 | argument to GHC, either on the command line or via cabal. Same trick also works for GHCi.* 20 | 21 | The `Proved` type simply wraps over the type of the predicate you are trying to prove, typically a function 22 | returning a `Bool` value. It tells the plugin to treat the input as a theorem that needs to be proved. 23 | When compiled, we get: 24 | 25 | ``` 26 | $ ghc -c Test.hs 27 | 28 | [SBV] Test.hs:8:1-4 Proving "test", using Z3. 29 | [Z3] Falsifiable. Counter-example: 30 | x = 0 :: Integer 31 | y = -1 :: Integer 32 | [SBV] Failed. (Use option 'IgnoreFailure' to continue.) 33 | ``` 34 | 35 | Note that the compilation will be aborted, since the theorem doesn't hold. If you load this file in GHCi, it will simply 36 | fail and drop you back to the GHCi prompt. 37 | 38 | ### Annotation style 39 | While the `Proved` type should suffice for simple uses, the plugin takes a number of arguments to modify 40 | options and pick underlying solvers. In this case, an explicit annotation can be provided: 41 | 42 | ```haskell 43 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 44 | 45 | module Test where 46 | 47 | import Data.SBV.Plugin 48 | 49 | {-# ANN test theorem {options = [IgnoreFailure]} #-} 50 | test :: Integer -> Integer -> Bool 51 | test x y = x == y -- clearly not True! 52 | ``` 53 | 54 | The above, for instance, tells the plugin to ignore failed proofs (`IgnoreFailure`). This is useful when you 55 | have a failing theorem that you are still working on, to make sure GHC continues compilation instead of stopping 56 | compilation and erroring out at that point. 57 | 58 | ### Available options 59 | 60 | The plugin currently understands the following options. Multiple options can be given at the same time 61 | by comma separating them. 62 | 63 | ```haskell 64 | data SBVOption = IgnoreFailure -- ^ Continue even if proof fails 65 | | Skip String -- ^ Skip the proof. Can be handy for properties that we currently do not want to focus on. 66 | | Verbose -- ^ Produce verbose output, good for debugging 67 | | Debug -- ^ Produce really verbose output, use only when things go really wrong! 68 | | QuickCheck -- ^ Perform quickCheck 69 | | Uninterpret -- ^ Uninterpret this binding for proof purposes 70 | | Names [String] -- ^ Use these names for the arguments; need not be exhaustive 71 | | ListSize Int -- ^ If a list-input is found, use this length. If not specified, we will complain! 72 | | Z3 -- ^ Use Z3 73 | | Yices -- ^ Use Yices 74 | | Boolector -- ^ Use Boolector 75 | | CVC4 -- ^ Use CVC4 76 | | CVC5 -- ^ Use CVC5 77 | | DReal -- ^ Use DReal 78 | | MathSAT -- ^ Use MathSAT 79 | | OpenSMT -- ^ Use OpenSMT 80 | | ABC -- ^ Use ABC 81 | | Bitwuzla -- ^ Use Bitwuzla 82 | | AnySolver -- ^ Run all installed solvers in parallel, and report the result from the first to finish 83 | ``` 84 | 85 | ### Using SBVPlugin from GHCi 86 | The plugin should work from GHCi with no changes. Note that when run from GHCi, the plugin will 87 | behave as if the `IgnoreFailure` argument is given on all annotations, so that failures do not stop 88 | the load process. 89 | 90 | ### Thanks 91 | The following people reported bugs, provided comments/feedback, or contributed to the development of SBVPlugin in 92 | various ways: Nickolas Fotopoulos and Stephan Renatus. 93 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | * Hackage: 2 | * GitHub: 3 | 4 | ### Version 9.12.1, 2025-03-12 5 | * Changes required to compile with GHC 9.12.1 6 | * Add support for CVC5, DReal, OpenSMT, and Bitwuzla as backend solvers 7 | * Bump up sbv dependence to >= 11.4 8 | 9 | ### Version 9.10.1, 2024-01-05 10 | * Changes required to compile with GHC 9.10.1 11 | * Bump up sbv dependence to >= 10.10 12 | 13 | ### Version 9.8.2, 2024-01-05 14 | * Changes required to compile with GHC 9.8.2 15 | * Bump up sbv dependence to >= 10.7 16 | 17 | ### Version 9.8.1, 2024-01-05 18 | * Changes required to compile with GHC 9.8.1 19 | * Bump up sbv dependence to >= 10.3 20 | 21 | ### Version 9.6.1, 2023-04-14 22 | * Changes required to compile with GHC 9.6.1 23 | * Bump up sbv dependence to >= 10.1 24 | 25 | ### Version 9.4.4, 2023-01-16 26 | * Changes required to compile with GHC 9.4.4 27 | * Bump up sbv dependence to >= 9.2 28 | 29 | ### Version 9.2.2, 2022-04-27 30 | * Changes required to compile with GHC 9.2.2 31 | * Bump up sbv dependence to >= 9.0 32 | 33 | ### Version 9.0.1, 2021-03-22 34 | * Changes required to compile with GHC 9.0.1 35 | * SBVPlugin version now matches the version of GHC we compiled it with. 36 | It might work with newer versions of GHC, though not tested/guaranteed. 37 | * Bump up sbv dependence to >= 8.13 38 | 39 | ### Version 0.12, 2020-09-05 40 | * Changes required to compile with GHC 8.10.2 41 | * Bump up sbv dependence to >= 8.8 42 | 43 | ### Version 0.11, 2019-01-14 44 | * Changes required to compile with GHC 8.6.3 45 | * Bump up sbv dependence to >= 8.0 46 | * Clean-up/improve test cases 47 | 48 | ### Version 0.10, 2017-07-29 49 | * Changes required to compile with GHC 8.2.1/8.2.2. 50 | * Bump up sbv dependence to >= 7.4 51 | 52 | ### Version 0.9, 2017-07-19 53 | * Sync-up with recent modifications to SBV. No user visible changes. 54 | * Bump up sbv dependence to >= 7.0 55 | 56 | ### Version 0.8, 2017-01-12 57 | * Fix broken links, thanks to Stephan Renatus for the patch. 58 | * Add the 'Proved' type, which allows for easily tagging a type for proof, 59 | without the need for an explicit annotation. Thanks to Nickolas Fotopoulos 60 | for the patch. 61 | * Bump up sbv dependence to > 5.14 62 | 63 | ### Version 0.7, 2016-06-06 64 | * Compile with GHC-8.0. Plugin at least requires GHC-8.0.1 and SBV 5.12 65 | * Fix a few dead links 66 | 67 | ### Version 0.6, 2016-01-01 68 | * Support for list expressions of the form [x .. y] and 69 | [x, y .. z]; so long as the x, y, and z are all concrete. 70 | * Simplify some of the expressions in BitTricks using 71 | the new list-construction support. 72 | * Added more proofs to the BitTricks example 73 | 74 | ### Version 0.5, 2015-12-26 75 | * Allow higher-order (i.e., function) arguments to theorems. 76 | * Rework uninterpreted functions, generalize types 77 | * Simplify cabal file; no need to ship gold-files for tests 78 | * Add merge-sort example "Data/SBV/Plugin/Examples/MergeSort.hs" 79 | * Add bit-tricks example "Data/SBV/Plugin/Examples/BitTricks.hs" 80 | 81 | ### Version 0.4, 2015-12-24 82 | * Support for case-alternatives producing lists/tuples 83 | and functions. In the list case, we require that both 84 | alternatives produce equal-length lists, as otherwise 85 | there is no way to merge the two results. 86 | * More test cases. 87 | 88 | ### Version 0.3, 2015-12-21 89 | * Added the micro-controller example, adapted from 90 | the original SBV variant by Anthony Cowley: 91 | 92 | * Add the "skip" option for the plugin itself. Handy when 93 | compiling the plugin itself! 94 | 95 | ### Version 0.2, 2015-12-21 96 | * Further fleshing of internals 97 | * Support for case-expressions 98 | * Support for uninterpreted types/functions 99 | * Lots of test cases, refactoring. 100 | 101 | ### Version 0.1, 2015-12-06 102 | * Basic functionality. Initial design exploration. 103 | * The plugin functional on base values, but there 104 | are a lot of rough edges around the details. 105 | Please report any issues you might find! 106 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Plugin.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Analyze 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Main entry point to the SBV Plugin 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE NamedFieldPuns #-} 13 | 14 | {-# OPTIONS_GHC -Wall -Werror #-} 15 | 16 | module Data.SBV.Plugin.Plugin(plugin) where 17 | 18 | import GHC.Plugins 19 | import System.Exit 20 | 21 | import Data.Maybe (fromJust) 22 | import Data.List (sortBy) 23 | import Data.Bits (bitSizeMaybe) 24 | 25 | import Data.IORef 26 | 27 | import qualified Data.Map as M 28 | 29 | import Data.SBV.Plugin.Common 30 | import Data.SBV.Plugin.Env 31 | import Data.SBV.Plugin.Analyze (analyzeBind) 32 | 33 | -- | Entry point to the plugin 34 | plugin :: Plugin 35 | plugin = defaultPlugin {installCoreToDos = install} 36 | where install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] 37 | install [] todos = return (sbvPass : todos) 38 | install ["skip"] todos = return todos 39 | install ["runLast"] todos = return (todos ++ [sbvPass]) 40 | install opts _ = do liftIO $ putStrLn $ "[SBV] Unexpected command line options: " ++ show opts 41 | liftIO $ putStrLn "" 42 | liftIO $ putStrLn "Options:" 43 | liftIO $ putStrLn " skip (does not run the plugin)" 44 | liftIO $ putStrLn " runLast (run the SBVPlugin last in the pipeline)" 45 | liftIO exitFailure 46 | 47 | sbvPass = CoreDoPluginPass "SBV based analysis" pass 48 | 49 | pass :: ModGuts -> CoreM ModGuts 50 | pass guts@ModGuts{mg_binds} = do 51 | 52 | df <- getDynFlags 53 | anns <- snd <$> getAnnotations deserializeWithData guts 54 | 55 | let wsz = fromJust (bitSizeMaybe (0::Int)) 56 | 57 | baseTCs <- buildTCEnv wsz 58 | baseEnv <- buildFunEnv wsz 59 | baseDests <- buildDests 60 | uninteresting <- uninterestingTypes 61 | specials <- buildSpecials 62 | 63 | rUninterpreted <- liftIO $ newIORef [] 64 | rUsedNames <- liftIO $ newIORef [] 65 | rUITypes <- liftIO $ newIORef [] 66 | 67 | let cfg = Config { isGHCi = ghcMode df == CompManager 68 | , opts = [] 69 | , sbvAnnotation = lookupWithDefaultUFM anns [] . varName 70 | , cfgEnv = Env { curLoc = [] 71 | , flags = df 72 | , machWordSize = wsz 73 | , mbListSize = Nothing 74 | , uninteresting = uninteresting 75 | , rUninterpreted = rUninterpreted 76 | , rUsedNames = rUsedNames 77 | , rUITypes = rUITypes 78 | , specials = specials 79 | , tcMap = baseTCs 80 | , envMap = baseEnv 81 | , destMap = baseDests 82 | , bailOut = \s ss -> error $ unlines (s:ss) 83 | , coreMap = M.fromList [(b, (varSpan b, e)) | (b, e) <- flattenBinds mg_binds] 84 | } 85 | } 86 | 87 | let bindLoc (NonRec b _) = varSpan b 88 | bindLoc (Rec []) = noSrcSpan 89 | bindLoc (Rec ((b, _):_)) = varSpan b 90 | 91 | cmp a b = bindLoc a `leftmost_smallest` bindLoc b 92 | 93 | mapM_ (analyzeBind cfg) $ sortBy cmp mg_binds 94 | 95 | return guts 96 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Examples/MergeSort.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Examples.MergeSort 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- An implementation of merge-sort and its correctness. 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE CPP #-} 13 | 14 | #ifndef HADDOCK 15 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 16 | #endif 17 | 18 | {-# OPTIONS_GHC -Wall -Werror #-} 19 | 20 | module Data.SBV.Plugin.Examples.MergeSort where 21 | 22 | #ifndef HADDOCK 23 | import Data.SBV.Plugin 24 | #endif 25 | 26 | ----------------------------------------------------------------------------- 27 | -- * Implementing merge-sort 28 | -- ${mergeSort} 29 | ----------------------------------------------------------------------------- 30 | {- $mergeSort 31 | A straightforward implementation of merge sort. We simply divide the input list 32 | in to two halves so long as it has at least two elements, sort each half on its 33 | own, and then merge. 34 | -} 35 | 36 | -- | Merging two given sorted lists, preserving the order. 37 | merge :: [Int] -> [Int] -> [Int] 38 | merge [] ys = ys 39 | merge xs [] = xs 40 | merge xs@(x:xr) ys@(y:yr) 41 | | x < y = x : merge xr ys 42 | | True = y : merge xs yr 43 | 44 | -- | Simple merge-sort implementation. 45 | mergeSort :: [Int] -> [Int] 46 | mergeSort [] = [] 47 | mergeSort [x] = [x] 48 | mergeSort xs = merge (mergeSort th) (mergeSort bh) 49 | where (th, bh) = halve xs ([], []) 50 | halve :: [Int] -> ([Int], [Int]) -> ([Int], [Int]) 51 | halve [] sofar = sofar 52 | halve (a:as) (fs, ss) = halve as (ss, a:fs) 53 | 54 | ----------------------------------------------------------------------------- 55 | -- * Proving correctness of sorting 56 | -- ${props} 57 | ----------------------------------------------------------------------------- 58 | {- $props 59 | There are two main parts to proving that a sorting algorithm is correct: 60 | 61 | * Prove that the output is non-decreasing 62 | 63 | * Prove that the output is a permutation of the input 64 | -} 65 | 66 | -- | Check whether a given sequence is non-decreasing. 67 | nonDecreasing :: [Int] -> Bool 68 | nonDecreasing [] = True 69 | nonDecreasing [_] = True 70 | nonDecreasing (a:b:xs) = a <= b && nonDecreasing (b:xs) 71 | 72 | -- | Check whether two given sequences are permutations. We simply check that each sequence 73 | -- is a subset of the other, when considered as a set. The check is slightly complicated 74 | -- for the need to account for possibly duplicated elements. 75 | isPermutationOf :: [Int] -> [Int] -> Bool 76 | isPermutationOf as bs = go as [(b, True) | b <- bs] && go bs [(a, True) | a <- as] 77 | where go :: [Int] -> [(Int, Bool)] -> Bool 78 | go [] _ = True 79 | go (x:xs) ys = found && go xs ys' 80 | where (found, ys') = mark x ys 81 | 82 | -- Go and mark off an instance of 'x' in the list, if possible. We keep track 83 | -- of unmarked elements by associating a boolean bit. Note that we have to 84 | -- keep the lists equal size for the recursive result to merge properly. 85 | mark :: Int -> [(Int, Bool)] -> (Bool, [(Int, Bool)]) 86 | mark _ [] = (False, []) 87 | mark x ((y, v) : ys) 88 | | v && x == y = (True, (y, not v) : ys) 89 | | True = (r, (y, v) : ys') 90 | where (r, ys') = mark x ys 91 | 92 | ----------------------------------------------------------------------------- 93 | -- * The correctness theorem 94 | ----------------------------------------------------------------------------- 95 | 96 | -- | Asserting correctness of merge-sort for a list of the given size. Note that we can 97 | -- only check correctness for fixed-size lists. Also, the proof will get more and more 98 | -- complicated for the backend SMT solver as @n@ increases. Here we try it with 4. 99 | -- 100 | -- We have: 101 | -- 102 | -- @ 103 | -- [SBV] tests/T48.hs:100:1-16 Proving "mergeSortCorrect", using Z3. 104 | -- [Z3] Q.E.D. 105 | -- @ 106 | #ifndef HADDOCK 107 | {-# ANN mergeSortCorrect theorem { options = [ListSize 4] } #-} 108 | #endif 109 | mergeSortCorrect :: [Int] -> Bool 110 | mergeSortCorrect xs = nonDecreasing ys && isPermutationOf xs ys 111 | where ys = mergeSort xs 112 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Examples/BitTricks.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Examples.BitTricks 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Checks the correctness of a few tricks from the large collection found in: 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE CPP #-} 14 | 15 | #ifndef HADDOCK 16 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 17 | #endif 18 | 19 | {-# OPTIONS_GHC -Wall -Werror #-} 20 | 21 | module Data.SBV.Plugin.Examples.BitTricks where 22 | 23 | import Data.SBV.Plugin 24 | 25 | import Data.Bits 26 | import Data.Word 27 | 28 | import Prelude hiding(elem) 29 | 30 | -- | SBVPlugin can only see definitions in the current module. So we define `elem` ourselves. 31 | -- Also, it has to be monomoprhized, as the plugin isn't smart enough to deal with polymorphic 32 | -- functions out-of-the-box. 33 | elem :: Word32 -> [Word32] -> Bool 34 | elem _ [] = False 35 | elem k (x:xs) = k == x || elem k xs 36 | 37 | -- | Returns 1 if bool is @True@ 38 | oneIf :: Num a => Bool -> a 39 | oneIf True = 1 40 | oneIf False = 0 41 | 42 | -- | Formalizes 43 | fastMinCorrect :: Proved (Int -> Int -> Bool) 44 | fastMinCorrect x y = m == fm 45 | where m = if x < y then x else y 46 | fm = y `xor` ((x `xor` y) .&. (-(oneIf (x < y)))); 47 | 48 | -- | Formalizes 49 | fastMaxCorrect :: Proved (Int -> Int -> Bool) 50 | fastMaxCorrect x y = m == fm 51 | where m = if x < y then y else x 52 | fm = x `xor` ((x `xor` y) .&. (-(oneIf (x < y)))); 53 | 54 | -- | Formalizes 55 | oppositeSignsCorrect :: Proved (Int -> Int -> Bool) 56 | oppositeSignsCorrect x y = r == os 57 | where r = (x < 0 && y >= 0) || (x >= 0 && y < 0) 58 | os = (x `xor` y) < 0 59 | 60 | -- | Formalizes 61 | conditionalSetClearCorrect :: Proved (Bool -> Word32 -> Word32 -> Bool) 62 | conditionalSetClearCorrect f m w = r == r' 63 | where r | f = w .|. m 64 | | True = w .&. complement m 65 | r' = w `xor` ((-(oneIf f) `xor` w) .&. m) 66 | 67 | -- | Formalizes 68 | powerOfTwoCorrect :: Proved (Word32 -> Bool) 69 | powerOfTwoCorrect v = f == (v `elem` [2^i | i <- [(0 :: Word32) .. 31]]) 70 | where f = (v /= 0) && ((v .&. (v-1)) == 0) 71 | 72 | -- | Formalizes 73 | maskedMergeCorrect :: Proved (Word32 -> Word32 -> Word32 -> Bool) 74 | maskedMergeCorrect a b mask = slow == fast 75 | where slow = (a .&. complement mask) .|. (b .&. mask) 76 | fast = a `xor` ((a `xor` b) .&. mask) 77 | 78 | -- | Formalizes 79 | roundPowerOfTwoCorrect :: Proved (Word32 -> Bool) 80 | roundPowerOfTwoCorrect v = f == find [2^i | i <- [(0 :: Word32) .. 31]] 81 | where f = let v1 = v - 1 82 | v2 = v1 .|. (v1 `shiftR` 1) 83 | v3 = v2 .|. (v2 `shiftR` 2) 84 | v4 = v3 .|. (v3 `shiftR` 4) 85 | v5 = v4 .|. (v4 `shiftR` 8) 86 | v6 = v5 .|. (v5 `shiftR` 16) 87 | v7 = v6 + 1 88 | v8 = v7 + oneIf (v7 == 0) 89 | in v8 90 | 91 | -- walk down the powers and return the closest one up 92 | find :: [Word32] -> Word32 93 | find [] = 1 94 | find (x:xs) 95 | | v > x = find xs 96 | | True = x 97 | 98 | -- | Formalizes 99 | zeroInWord :: Proved (Word32 -> Bool) 100 | zeroInWord v = hasZero == fastHasZero 101 | where b3 = (v .&. 0xFF000000) == 0 102 | b2 = (v .&. 0x00FF0000) == 0 103 | b1 = (v .&. 0x0000FF00) == 0 104 | b0 = (v .&. 0x000000FF) == 0 105 | hasZero = b3 || b2 || b1 || b0 106 | 107 | fastHasZero = ((v - 0x01010101) .&. complement v .&. 0x80808080) /= 0 108 | 109 | {-# ANN module ("HLint: ignore Use min" :: String) #-} 110 | {-# ANN module ("HLint: ignore Use max" :: String) #-} 111 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Examples/MicroController.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Examples.MicroController 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- A transcription of Anthony Cowley's MicroController example, using 10 | -- the SBV plugin. For the original, see: 11 | -- 12 | ----------------------------------------------------------------------------- 13 | 14 | {-# LANGUAGE CPP #-} 15 | 16 | #ifndef HADDOCK 17 | {-# OPTIONS_GHC -fplugin=Data.SBV.Plugin #-} 18 | #endif 19 | 20 | {-# OPTIONS_GHC -Wall -Werror #-} 21 | 22 | module Data.SBV.Plugin.Examples.MicroController where 23 | 24 | import Data.SBV.Plugin 25 | 26 | ----------------------------------------------------------------------------- 27 | -- * Parameters 28 | ----------------------------------------------------------------------------- 29 | 30 | -- | The range detector must output if the range is larger than this amount. 31 | safetyDistance :: Int 32 | safetyDistance = 200 33 | 34 | -- | The range detector must have sent an output before this many cycles have past. 35 | maxTimeSince :: Int 36 | maxTimeSince = 10 37 | 38 | ----------------------------------------------------------------------------- 39 | -- * The specification 40 | ----------------------------------------------------------------------------- 41 | 42 | -- | Given a last-signal-time calculator, named @calculate@, check that it satisfies the following 43 | -- three requirements: We must've just sent a signal if: 44 | -- 45 | -- * /minRate/: The last-time we sent is strictly less than the 'maxTimeSince' amount 46 | -- * /minRange/: We must've just sent a signal if the range is beyond 'safetyDistance' 47 | -- * /manualOverride/: We must've just sent a signal if the manual-override is specified 48 | checkSpec :: (Int -> Bool -> Int -> Int) -> Int -> Bool -> Int -> Bool 49 | checkSpec calculate r m t = minRate && minRange && manualOverride 50 | 51 | where sinceLast = calculate r m t 52 | 53 | -- Never exceed the max-time allowed 54 | minRate = sinceLast < maxTimeSince 55 | 56 | -- If the range is exceeded, always send a signal 57 | minRange = r <= safetyDistance || sinceLast == 0 58 | 59 | -- Manual override, always signals 60 | manualOverride = not m || sinceLast == 0 61 | 62 | ----------------------------------------------------------------------------- 63 | -- * A bad implementation 64 | ----------------------------------------------------------------------------- 65 | 66 | -- | A "bad" implementation, see if you can spot the problem with it, before looking 67 | -- at the failed theorem below! 68 | computeLastBad :: Int -> Bool -> Int -> Int 69 | computeLastBad range manual timeSince 70 | | range > safetyDistance = 0 71 | | manual = 0 72 | | timeSince > maxTimeSince - 1 = 0 73 | | True = timeSince + 1 74 | 75 | -- | Using SBV, prove that the 'computeLastBad' is indeed a bad implementation. Here's the output 76 | -- we get from the plugin: 77 | -- 78 | -- @ 79 | -- [SBV] MicroController.hs:85:1-8 Proving "checkBad", using Z3. 80 | -- [Z3] Falsifiable. Counter-example: 81 | -- range = 200 :: Int64 82 | -- manual = False :: Bool 83 | -- timeSince = 9 :: Int64 84 | -- @ 85 | -- 86 | -- We're being told that if the range is 200, and manual override is off, and time-since last is 9, 87 | -- then our "calculator" returns 10. But that violates the @minRate@ requirement, since we 88 | -- never want to go 'maxTimeSince' cycles without sending a signal! 89 | #ifndef HADDOCK 90 | {-# ANN checkBad theorem {options = [IgnoreFailure]} #-} 91 | #endif 92 | checkBad :: Int -> Bool -> Int -> Bool 93 | checkBad range manual timeSince = checkSpec computeLastBad range manual timeSince 94 | 95 | ----------------------------------------------------------------------------- 96 | -- * A correct implementation 97 | ----------------------------------------------------------------------------- 98 | 99 | -- | A "good" implementation, properly handling the off-by-one error of the original. 100 | computeLastGood :: Int -> Bool -> Int -> Int 101 | computeLastGood range manual timeSince 102 | | range > safetyDistance = 0 103 | | manual = 0 104 | | timeSince > maxTimeSince - 2 = 0 105 | | True = timeSince + 1 106 | 107 | -- | We now verify that the good variant is indeed good. 108 | -- We have: 109 | -- 110 | -- @ 111 | -- [SBV] MicroController.hs:108:1-9 Proving "checkGood", using Z3. 112 | -- [Z3] Q.E.D. 113 | -- @ 114 | checkGood :: Proved (Int -> Bool -> Int -> Bool) 115 | checkGood range manual timeSince = checkSpec computeLastGood range manual timeSince 116 | 117 | ----------------------------------------------------------------------------- 118 | -- * Exercise for the reader 119 | -- $exercise 120 | ----------------------------------------------------------------------------- 121 | {- $exercise 122 | It is easy to see that an implementation that always returns @0@ (i.e., one that always 123 | sends a signal) will also pass our specification! 124 | 125 | * First, use the plugin to prove that such an implementation is indeed accepted. 126 | 127 | * Then, modify the spec so that we require the @timeSince@ parameter to actually get 128 | incremented under the correct conditions. 129 | 130 | * Show that your new spec outlaws the always @0@ producing implementation. 131 | -} 132 | 133 | {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} 134 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'sbvPlugin.cabal' '--no-tests' '--no-benchmarks' '--no-doctest' '--no-hlint' '--email-notifications' '--no-haddock' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20240316 12 | # 13 | # REGENDATA ("0.19.20240316",["github","sbvPlugin.cabal","--no-tests","--no-benchmarks","--no-doctest","--no-hlint","--email-notifications","--no-haddock"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.10.1 32 | compilerKind: ghc 33 | compilerVersion: 9.10.1 34 | setup-method: ghcup 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | mkdir -p "$HOME/.ghcup/bin" 43 | curl -sL https://downloads.haskell.org/ghcup/0.1.22.0/x86_64-linux-ghcup-0.1.22.0 > "$HOME/.ghcup/bin/ghcup" 44 | chmod a+x "$HOME/.ghcup/bin/ghcup" 45 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 46 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 47 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.3.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 48 | env: 49 | HCKIND: ${{ matrix.compilerKind }} 50 | HCNAME: ${{ matrix.compiler }} 51 | HCVER: ${{ matrix.compilerVersion }} 52 | - name: Set PATH and environment variables 53 | run: | 54 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 55 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 56 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 57 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 58 | HCDIR=/opt/$HCKIND/$HCVER 59 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 60 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 61 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 62 | echo "HC=$HC" >> "$GITHUB_ENV" 63 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 64 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 65 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.3.0 -vnormal+nowrap" >> "$GITHUB_ENV" 66 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 67 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 68 | echo "ARG_TESTS=--disable-tests" >> "$GITHUB_ENV" 69 | echo "ARG_BENCH=--disable-benchmarks" >> "$GITHUB_ENV" 70 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 71 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 72 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 73 | env: 74 | HCKIND: ${{ matrix.compilerKind }} 75 | HCNAME: ${{ matrix.compiler }} 76 | HCVER: ${{ matrix.compilerVersion }} 77 | - name: env 78 | run: | 79 | env 80 | - name: write cabal config 81 | run: | 82 | mkdir -p $CABAL_DIR 83 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 116 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 117 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 118 | rm -f cabal-plan.xz 119 | chmod a+x $HOME/.cabal/bin/cabal-plan 120 | cabal-plan --version 121 | - name: checkout 122 | uses: actions/checkout@v3 123 | with: 124 | path: source 125 | - name: initial cabal.project for sdist 126 | run: | 127 | touch cabal.project 128 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 129 | cat cabal.project 130 | - name: sdist 131 | run: | 132 | mkdir -p sdist 133 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 134 | - name: unpack 135 | run: | 136 | mkdir -p unpacked 137 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 138 | - name: generate cabal.project 139 | run: | 140 | PKGDIR_sbvPlugin="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/sbvPlugin-[0-9.]*')" 141 | echo "PKGDIR_sbvPlugin=${PKGDIR_sbvPlugin}" >> "$GITHUB_ENV" 142 | rm -f cabal.project cabal.project.local 143 | touch cabal.project 144 | touch cabal.project.local 145 | echo "packages: ${PKGDIR_sbvPlugin}" >> cabal.project 146 | echo "package sbvPlugin" >> cabal.project 147 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 148 | cat >> cabal.project <> cabal.project.local 151 | cat cabal.project 152 | cat cabal.project.local 153 | - name: dump install plan 154 | run: | 155 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 156 | cabal-plan 157 | - name: restore cache 158 | uses: actions/cache/restore@v3 159 | with: 160 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 161 | path: ~/.cabal/store 162 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 163 | - name: install dependencies 164 | run: | 165 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 166 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 167 | - name: build w/o tests 168 | run: | 169 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 170 | - name: build 171 | run: | 172 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 173 | - name: cabal check 174 | run: | 175 | cd ${PKGDIR_sbvPlugin} || false 176 | ${CABAL} -vnormal check 177 | - name: unconstrained build 178 | run: | 179 | rm -f cabal.project.local 180 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 181 | - name: save cache 182 | uses: actions/cache/save@v3 183 | if: always() 184 | with: 185 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 186 | path: ~/.cabal/store 187 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Common.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Common 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Common data-structures/utilities 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | 15 | {-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} 16 | 17 | module Data.SBV.Plugin.Common where 18 | 19 | import Control.Monad (zipWithM, mplus) 20 | import Control.Monad.Reader 21 | 22 | import GHC.Plugins 23 | import qualified GHC.Data.Strict as GDS (Maybe(Nothing)) 24 | 25 | import GHC.Types.Tickish 26 | import GHC.Types.CostCentre 27 | import GHC.Types.Unique (nonDetCmpUnique) 28 | 29 | import Data.Maybe (mapMaybe) 30 | import qualified Data.Map as M 31 | 32 | import Data.IORef 33 | 34 | import qualified Data.SBV as S 35 | import qualified Data.SBV.Dynamic as S 36 | 37 | import Data.SBV.Plugin.Data 38 | 39 | -- | Certain "very-polymorphic" things are just special 40 | data Specials = Specials { isEquality :: Var -> Maybe Val 41 | , isTuple :: Var -> Maybe Val 42 | , isList :: Var -> Maybe Val 43 | } 44 | 45 | -- | TyCon's are no longer Ord in GHC 8.2.1; so we make a newtype 46 | newtype TCKey = TCKey (TyCon, [TyCon]) 47 | 48 | -- | Extract the unique "key" 49 | tcKeyToUList :: TCKey -> [Unique] 50 | tcKeyToUList (TCKey (a, as)) = map getUnique (a:as) 51 | 52 | -- | Make a rudimentary Eq instance for TCKey 53 | instance Eq TCKey where 54 | k1 == k2 = tcKeyToUList k1 == tcKeyToUList k2 55 | 56 | -- | Make a rudimentary Ord instance for TCKey 57 | instance Ord TCKey where 58 | k1 `compare` k2 = tcKeyToUList k1 `cmp` tcKeyToUList k2 59 | where [] `cmp` [] = EQ 60 | [] `cmp` _ = LT 61 | _ `cmp` [] = GT 62 | (a:as) `cmp` (b:bs) = case a `nonDetCmpUnique` b of 63 | EQ -> as `cmp` bs 64 | r -> r 65 | 66 | -- | Interpreter environment 67 | data Env = Env { curLoc :: [SrcSpan] 68 | , flags :: DynFlags 69 | , machWordSize :: Int 70 | , mbListSize :: Maybe Int 71 | , uninteresting :: [Type] 72 | , rUninterpreted :: IORef [((Var, Type), (Bool, String, Val))] 73 | , rUsedNames :: IORef [String] 74 | , rUITypes :: IORef [(Type, S.Kind)] 75 | , specials :: Specials 76 | , tcMap :: M.Map TCKey S.Kind 77 | , envMap :: M.Map (Var, SKind) Val 78 | , destMap :: M.Map Var (Val -> [(Var, SKind)] -> (S.SVal, [((Var, SKind), Val)])) 79 | , coreMap :: M.Map Var (SrcSpan, CoreExpr) 80 | , bailOut :: forall a. String -> [String] -> Eval a 81 | } 82 | 83 | 84 | -- | The interpreter monad 85 | type Eval a = ReaderT Env S.Symbolic a 86 | 87 | -- | Configuration info as we run the plugin 88 | data Config = Config { isGHCi :: Bool 89 | , opts :: [SBVAnnotation] 90 | , sbvAnnotation :: Var -> [SBVAnnotation] 91 | , cfgEnv :: Env 92 | } 93 | 94 | -- | Given the user options, determine which solver(s) to use 95 | pickSolvers :: [SBVOption] -> IO [S.SMTConfig] 96 | pickSolvers slvrs 97 | | AnySolver `elem` slvrs = S.getAvailableSolvers 98 | | True = case mapMaybe (`lookup` solvers) slvrs of 99 | [] -> return [S.defaultSMTCfg] 100 | xs -> return xs 101 | where solvers = [ (Z3, S.z3) 102 | , (Yices, S.yices) 103 | , (Boolector, S.boolector) 104 | , (CVC4, S.cvc4) 105 | , (CVC5, S.cvc5) 106 | , (MathSAT, S.mathSAT) 107 | , (ABC, S.abc) 108 | , (DReal, S.dReal) 109 | , (OpenSMT, S.openSMT) 110 | , (Bitwuzla, S.bitwuzla) 111 | ] 112 | 113 | -- | The kinds used by the plugin 114 | data SKind = KBase S.Kind 115 | | KTup [SKind] 116 | | KLst SKind 117 | | KFun SKind SKind 118 | deriving (Eq, Ord) 119 | 120 | -- | The values kept track of by the interpreter 121 | data Val = Base S.SVal 122 | | Typ SKind 123 | | Tup [Val] 124 | | Lst [Val] 125 | | Func (Maybe String) (Val -> Eval Val) 126 | 127 | -- | Outputable instance for SKind 128 | instance Outputable SKind where 129 | ppr (KBase k) = text (show k) 130 | ppr (KTup ks) = parens $ sep (punctuate (text ",") (map ppr ks)) 131 | ppr (KLst k) = brackets $ ppr k 132 | ppr (KFun k r) = parens (ppr k) <+> text "->" <+> ppr r 133 | 134 | -- | Outputable instance for S.Kind 135 | instance Outputable S.Kind where 136 | ppr = text . show 137 | 138 | -- | Outputable instance for Val 139 | instance Outputable Val where 140 | ppr (Base s) = text (show s) 141 | ppr (Typ k) = ppr k 142 | ppr (Tup vs) = parens $ sep $ punctuate (text ",") (map ppr vs) 143 | ppr (Lst vs) = brackets $ sep $ punctuate (text ",") (map ppr vs) 144 | ppr (Func k _) = text ("Func<" ++ show k ++ ">") 145 | 146 | -- | Structural lifting of a boolean function (eq/neq) over Val 147 | liftEqVal :: (S.SVal -> S.SVal -> S.SVal) -> Val -> Val -> S.SVal 148 | liftEqVal baseEq v1 v2 = k v1 v2 149 | where k (Base a) (Base b) = a `baseEq` b 150 | k (Tup as) (Tup bs) | length as == length bs = foldr S.svAnd S.svTrue (zipWith k as bs) 151 | k (Lst as) (Lst bs) = foldr S.svAnd (S.svBool (length as == length bs)) (zipWith k as bs) 152 | k _ _ = error $ "Impossible happened: liftEq received unexpected arguments: " ++ showSDocUnsafe (ppr (v1, v2)) 153 | 154 | -- | Symbolic equality over values 155 | eqVal :: Val -> Val -> S.SVal 156 | eqVal = liftEqVal S.svEqual 157 | 158 | -- | Symbolic if-then-else over values. 159 | iteVal :: ([String] -> Eval Val) -> S.SVal -> Val -> Val -> Eval Val 160 | iteVal die t v1 v2 = k v1 v2 161 | where k (Base a) (Base b) = return $ Base $ S.svIte t a b 162 | k (Tup as) (Tup bs) | length as == length bs = Tup `fmap` zipWithM k as bs 163 | k (Lst as) (Lst bs) | length as == length bs = Lst `fmap` zipWithM k as bs 164 | | True = die [ "Alternatives are producing lists of differing sizes:" 165 | , " Length " ++ show (length as) ++ ": " ++ showSDocUnsafe (ppr (Lst as)) 166 | , "vs Length " ++ show (length bs) ++ ": " ++ showSDocUnsafe (ppr (Lst bs)) 167 | ] 168 | k (Func n1 f) (Func n2 g) = return $ Func (n1 `mplus` n2) $ \a -> f a >>= \fa -> g a >>= \ga -> k fa ga 169 | k _ _ = die [ "Unsupported if-then-else/case with alternatives:" 170 | , " Value:" ++ showSDocUnsafe (ppr v1) 171 | , " vs:" ++ showSDocUnsafe (ppr v2) 172 | ] 173 | 174 | -- | Compute the span given a Tick. Returns the old-span if the tick span useless. 175 | tickSpan :: GenTickish t -> SrcSpan 176 | tickSpan (ProfNote cc _ _) = cc_loc cc 177 | tickSpan (SourceNote s _) = RealSrcSpan s GDS.Nothing 178 | tickSpan _ = noSrcSpan 179 | 180 | -- | Compute the span for a binding. 181 | varSpan :: Var -> SrcSpan 182 | varSpan = nameSrcSpan . varName 183 | 184 | -- | Pick the first "good" span, hopefully corresponding to 185 | -- the closest location to where we are in the code 186 | -- when we issue an error message. 187 | pickSpan :: [SrcSpan] -> SrcSpan 188 | pickSpan ss = case filter isGoodSrcSpan ss of 189 | (s:_) -> s 190 | [] -> noSrcSpan 191 | 192 | -- | Show a GHC span in user-friendly form 193 | showSpan :: DynFlags -> SrcSpan -> String 194 | showSpan fs s = showSDoc fs (ppr s) 195 | 196 | -- | This comes mighty handy! Wonder why GHC doesn't have it already: 197 | instance Show CoreExpr where 198 | show = go 199 | where sh x = showSDocUnsafe (ppr x) 200 | go (Var i) = "(Var " ++ sh i ++ ")" 201 | go (Lit l) = "(Lit " ++ sh l ++ ")" 202 | go (App f a) = "(App " ++ go f ++ " " ++ go a ++ ")" 203 | go (Lam b e) = "(Lam " ++ sh b ++ " " ++ go e ++ ")" 204 | go (Let b e) = "(Let " ++ sh b ++ " " ++ go e ++ ")" 205 | go (Case e b t _) = "(Case " ++ go e ++ " " ++ sh b ++ " " ++ sh t ++ "...)" 206 | go (Cast e _) = "(Cast " ++ go e ++ " ...)" 207 | go (Tick _ e) = "(Tick " ++ go e ++ ")" 208 | go (Type t) = "(Type " ++ sh t ++ ")" 209 | go (Coercion _) = "(Coercion ...)" 210 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Env.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Env 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- The environment for mapping concrete functions/types to symbolic ones. 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE MagicHash #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | {-# LANGUAGE TemplateHaskellQuotes #-} 15 | {-# LANGUAGE UnboxedTuples #-} 16 | 17 | {-# OPTIONS_GHC -Wall -Werror #-} 18 | 19 | module Data.SBV.Plugin.Env (buildTCEnv, buildFunEnv, buildDests, buildSpecials, uninterestingTypes) where 20 | 21 | import GHC.Plugins 22 | import GHC.Prim 23 | import GHC.Types hiding (Type, TyCon) 24 | import GHC.Types.TyThing 25 | 26 | import GHC.Unit.Finder 27 | import GHC.Iface.Env 28 | 29 | import qualified Data.Map as M 30 | import qualified Language.Haskell.TH as TH 31 | 32 | import Control.Monad.Reader 33 | 34 | import Data.Int 35 | import Data.Word 36 | import Data.Bits 37 | import Data.Maybe (fromMaybe, isJust) 38 | import Data.Ratio 39 | 40 | import qualified Data.SBV as S 41 | import qualified Data.SBV.Dynamic as S 42 | 43 | import Data.SBV.Plugin.Common 44 | 45 | -- | What tuple-sizes we support? We go upto 15, but would be easy to change if necessary 46 | supportTupleSizes :: [Int] 47 | supportTupleSizes = [2 .. 15] 48 | 49 | -- | Build the initial environment containing types 50 | buildTCEnv :: Int -> CoreM (M.Map TCKey S.Kind) 51 | buildTCEnv wsz = do xs <- mapM grabTyCon basics 52 | ys <- mapM grabTyApp apps 53 | return $ M.fromList [(TCKey k, v) | (k, v) <- xs ++ ys] 54 | 55 | where grab = grabTH lookupTyCon 56 | 57 | grabTyCon (x, k) = grabTyApp (x, [], k) 58 | 59 | grabTyApp (x, as, k) = do fn <- grab x 60 | args <- mapM grab as 61 | return ((fn, args), k) 62 | 63 | basics = concat [ [(t, S.KBool) | t <- [''Bool ]] 64 | , [(t, S.KUnbounded) | t <- [''Integer ]] 65 | , [(t, S.KFloat) | t <- [''Float, ''Float# ]] 66 | , [(t, S.KDouble) | t <- [''Double, ''Double#]] 67 | , [(t, S.KBounded True wsz) | t <- [''Int, ''Int# ]] 68 | , [(t, S.KBounded True 8) | t <- [''Int8 ]] 69 | , [(t, S.KBounded True 16) | t <- [''Int16 ]] 70 | , [(t, S.KBounded True 32) | t <- [''Int32, ''Int32# ]] 71 | , [(t, S.KBounded True 64) | t <- [''Int64, ''Int64# ]] 72 | , [(t, S.KBounded False wsz) | t <- [''Word, ''Word# ]] 73 | , [(t, S.KBounded False 8) | t <- [''Word8 ]] 74 | , [(t, S.KBounded False 16) | t <- [''Word16 ]] 75 | , [(t, S.KBounded False 32) | t <- [''Word32, ''Word32#]] 76 | , [(t, S.KBounded False 64) | t <- [''Word64, ''Word64#]] 77 | ] 78 | 79 | apps = [ (''Ratio, [''Integer], S.KReal) ] 80 | 81 | -- | Build the initial environment containing functions 82 | buildFunEnv :: Int -> CoreM (M.Map (Id, SKind) Val) 83 | buildFunEnv wsz = M.fromList `fmap` mapM thToGHC (basicFuncs wsz ++ symFuncs wsz) 84 | 85 | -- | Basic conversions, only on one kind 86 | basicFuncs :: Int -> [(TH.Name, SKind, Val)] 87 | basicFuncs wsz = [ ('F#, tlift1 (KBase S.KFloat), Func Nothing return) 88 | , ('D#, tlift1 (KBase S.KDouble), Func Nothing return) 89 | , ('I#, tlift1 (KBase (S.KBounded True wsz)), Func Nothing return) 90 | , ('W#, tlift1 (KBase (S.KBounded False wsz)), Func Nothing return) 91 | , ('True, KBase S.KBool, Base S.svTrue) 92 | , ('False, KBase S.KBool, Base S.svFalse) 93 | , ('(&&), tlift2 (KBase S.KBool), lift2 S.svAnd) 94 | , ('(||), tlift2 (KBase S.KBool), lift2 S.svOr) 95 | , ('not, tlift1 (KBase S.KBool), lift1 S.svNot) 96 | ] 97 | 98 | -- | Symbolic functions supported by the plugin; those from a class. 99 | symFuncs :: Int -> [(TH.Name, SKind, Val)] 100 | symFuncs wsz = -- equality is for all kinds 101 | [(op, tlift2Bool (KBase k), lift2 sOp) | k <- allKinds, (op, sOp) <- [('(==), S.svEqual), ('(/=), S.svNotEqual)]] 102 | 103 | -- arithmetic 104 | ++ [(op, tlift1 (KBase k), lift1 sOp) | k <- arithKinds, (op, sOp) <- unaryOps] 105 | ++ [(op, tlift2 (KBase k), lift2 sOp) | k <- arithKinds, (op, sOp) <- binaryOps] 106 | 107 | -- literal conversions from Integer 108 | ++ [(op, KFun (KBase S.KUnbounded) (KBase k), lift1Int sOp) | k <- integerKinds, (op, sOp) <- [('fromInteger, S.svInteger k)]] 109 | 110 | -- comparisons 111 | ++ [(op, tlift2Bool (KBase k), lift2 sOp) | k <- arithKinds, (op, sOp) <- compOps ] 112 | 113 | -- integer div/rem 114 | ++ [(op, tlift2 (KBase k), lift2 sOp) | k <- integralKinds, (op, sOp) <- [('div, S.svDivide), ('quot, S.svQuot), ('rem, S.svRem)]] 115 | 116 | -- bit-vector 117 | ++ [ (op, tlift2 (KBase k), lift2 sOp) | k <- bvKinds, (op, sOp) <- bvBinOps ] 118 | ++ [ (op, tlift2ShRot wsz (KBase k), lift2 sOp) | k <- bvKinds, (op, sOp) <- bvShiftRots] 119 | 120 | -- constructing "fixed-size" lists 121 | ++ [ ('enumFromTo, tEnumFromTo (KBase k), sEnumFromTo) | k <- arithKinds ] 122 | ++ [ ('enumFromThenTo, tEnumFromThenTo (KBase k), sEnumFromThenTo) | k <- arithKinds ] 123 | 124 | where 125 | -- Bit-vectors 126 | bvKinds = [S.KBounded s sz | s <- [False, True], sz <- [8, 16, 32, 64]] 127 | 128 | -- Those that are "integral"ish 129 | integralKinds = S.KUnbounded : bvKinds 130 | 131 | -- Those that can be converted from an Integer 132 | integerKinds = S.KReal : integralKinds 133 | 134 | -- Float kinds 135 | floatKinds = [S.KFloat, S.KDouble] 136 | 137 | -- All arithmetic kinds 138 | arithKinds = floatKinds ++ integerKinds 139 | 140 | -- Everything 141 | allKinds = S.KBool : arithKinds 142 | 143 | -- Unary arithmetic ops 144 | unaryOps = [ ('abs, S.svAbs) 145 | , ('negate, S.svUNeg) 146 | , ('complement, S.svNot) 147 | ] 148 | 149 | -- Binary arithmetic ops 150 | binaryOps = [ ('(+), S.svPlus) 151 | , ('(-), S.svMinus) 152 | , ('(*), S.svTimes) 153 | , ('(/), S.svDivide) 154 | , ('(^), S.svExp) 155 | , ('quot, S.svQuot) 156 | , ('rem, S.svRem) 157 | ] 158 | 159 | -- Comparisons 160 | compOps = [ ('(<), S.svLessThan) 161 | , ('(>), S.svGreaterThan) 162 | , ('(<=), S.svLessEq) 163 | , ('(>=), S.svGreaterEq) 164 | ] 165 | 166 | -- Binary bit-vector ops 167 | bvBinOps = [ ('(.&.), S.svAnd) 168 | , ('(.|.), S.svOr) 169 | , ('xor, S.svXOr) 170 | ] 171 | 172 | -- Shift/rotates, where second argument is an int 173 | bvShiftRots = [ ('shiftL, S.svShiftLeft) 174 | , ('shiftR, S.svShiftRight) 175 | , ('rotateL, S.svRotateLeft) 176 | , ('rotateR, S.svRotateRight) 177 | ] 178 | 179 | 180 | -- | Destructors 181 | buildDests :: CoreM (M.Map Var (Val -> [(Var, SKind)] -> (S.SVal, [((Var, SKind), Val)]))) 182 | buildDests = do simple <- mapM mkSingle dests 183 | tups <- mapM mkTuple supportTupleSizes 184 | nil <- mkNil 185 | cons <- mkCons 186 | return $ M.fromList (simple ++ tups ++ [nil, cons]) 187 | where 188 | dests = [ ('W#, dest1) 189 | , ('I#, dest1) 190 | , ('F#, dest1) 191 | , ('D#, dest1) 192 | ] 193 | 194 | dest1 a [bk] = (S.svTrue, [(bk, a)]) 195 | dest1 a bs = error $ "Impossible happened: Mistmatched arity case-binder for: " ++ showSDocUnsafe (ppr a) ++ ". Expected 1, got: " ++ show (length bs) ++ " arguments." 196 | 197 | mkSingle :: (TH.Name, b) -> CoreM (Id, b) 198 | mkSingle (n, sfn) = do f <- grabTH lookupId n 199 | return (f, sfn) 200 | 201 | mkTuple n = do d <- grabTH lookupId (TH.tupleDataName n) 202 | let dest (Tup xs) bs 203 | | length xs == n && length bs == n 204 | = (S.svTrue, zip bs xs) 205 | dest a b = error $ "Impossible: Tuple-case mismatch: " ++ showSDocUnsafe (ppr (n, a, b)) 206 | return (d, dest) 207 | 208 | mkNil = do d <- lookupId nilDataConName 209 | let dest (Lst []) [] = (S.svTrue, []) 210 | dest (Lst _) _ = (S.svFalse, []) 211 | dest a b = error $ "Impossible: []-case mismatch: " ++ showSDocUnsafe (ppr (a, b)) 212 | return (d, dest) 213 | 214 | mkCons = do d <- lookupId consDataConName 215 | let dest (Lst []) _ = (S.svFalse, []) 216 | dest (Lst (x:xs)) [h, t] = (S.svTrue, [(h, x), (t, Lst xs)]) 217 | dest a b = error $ "Impossible: (:)-case mismatch: " ++ showSDocUnsafe (ppr (a, b)) 218 | return (d, dest) 219 | 220 | -- | These types show up during uninterpretation, but are not really "interesting" as they 221 | -- are singly inhabited. 222 | uninterestingTypes :: CoreM [Type] 223 | uninterestingTypes = map varType `fmap` mapM (grabTH lookupId) ['(# #)] 224 | 225 | -- | Certain things are just too special, as they uniformly apply to uninterpreted types. 226 | buildSpecials :: CoreM Specials 227 | buildSpecials = do isEq <- do eq <- grabTH lookupId '(==) 228 | neq <- grabTH lookupId '(/=) 229 | 230 | let choose = [(eq, liftEq S.svEqual), (neq, liftEq S.svNotEqual)] 231 | 232 | return (`lookup` choose) 233 | 234 | isTup <- do let mkTup n = Func Nothing g 235 | where g (Typ _) = return $ Func Nothing g 236 | g v = h (n-1) [v] 237 | h 0 sofar = return $ Tup (reverse sofar) 238 | h i sofar = return $ Func Nothing $ \v -> h (i-1) (v:sofar) 239 | ts <- mapM (grabTH lookupId . TH.tupleDataName) supportTupleSizes 240 | let choose = zip ts (map mkTup supportTupleSizes) 241 | return (`lookup` choose) 242 | 243 | isLst <- do nil <- lookupId nilDataConName 244 | cons <- lookupId consDataConName 245 | 246 | let snil = Lst [] 247 | 248 | scons = Func Nothing g 249 | where g (Typ _) = return $ Func Nothing g 250 | g v = return $ Func Nothing (k v) 251 | k v (Lst xs) = return (Lst (v:xs)) 252 | k v a = error $ "Impossible: (:) received incompatible arguments: " ++ showSDocUnsafe (ppr (v, a)) 253 | 254 | choose = [(nil, snil), (cons, scons)] 255 | 256 | return (`lookup` choose) 257 | 258 | return Specials{ isEquality = isEq 259 | , isTuple = isTup 260 | , isList = isLst 261 | } 262 | 263 | -- | Lift a binary type, with result bool 264 | tlift2Bool :: SKind -> SKind 265 | tlift2Bool k = KFun k (KFun k (KBase S.KBool)) 266 | 267 | -- | Lift a unary type 268 | tlift1 :: SKind -> SKind 269 | tlift1 k = KFun k k 270 | 271 | -- | Lift a binary type 272 | tlift2 :: SKind -> SKind 273 | tlift2 k = KFun k (tlift1 k) 274 | 275 | -- | Lift a binary type, where second argument is Int 276 | tlift2ShRot :: Int -> SKind -> SKind 277 | tlift2ShRot wsz k = KFun k (KFun (KBase (S.KBounded True wsz)) k) 278 | 279 | -- | Type of enumFromTo: [x .. y] 280 | tEnumFromTo :: SKind -> SKind 281 | tEnumFromTo a = KFun a (KFun a (KLst a)) 282 | 283 | -- | Type of enumFromThenTo: [x .. y] 284 | tEnumFromThenTo :: SKind -> SKind 285 | tEnumFromThenTo a = KFun a (KFun a (KFun a (KLst a))) 286 | 287 | -- | Lift a unary SBV function that via kind/integer 288 | lift1Int :: (Integer -> S.SVal) -> Val 289 | lift1Int f = Func Nothing g 290 | where g (Base i) = return $ Base $ f (fromMaybe (error ("Cannot extract an integer from value: " ++ show i)) (S.svAsInteger i)) 291 | g _ = error "Impossible happened: lift1Int received non-base argument!" 292 | 293 | -- | Lift a unary SBV function to the plugin value space 294 | lift1 :: (S.SVal -> S.SVal) -> Val 295 | lift1 f = Func Nothing g 296 | where g (Typ _) = return $ Func Nothing h 297 | g v = h v 298 | h (Base a) = return $ Base $ f a 299 | h v = error $ "Impossible happened: lift1 received non-base argument: " ++ showSDocUnsafe (ppr v) 300 | 301 | -- | Lift a two argument SBV function to our the plugin value space 302 | lift2 :: (S.SVal -> S.SVal -> S.SVal) -> Val 303 | lift2 f = Func Nothing g 304 | where g (Typ _) = return $ Func Nothing h 305 | g v = h v 306 | h (Base a) = return $ Func Nothing (k a) 307 | h v = error $ "Impossible happened: lift2 received non-base argument (h): " ++ showSDocUnsafe (ppr v) 308 | k a (Base b) = return $ Base $ f a b 309 | k _ v = error $ "Impossible happened: lift2 received non-base argument (k): " ++ showSDocUnsafe (ppr v) 310 | 311 | -- | Lifting an equality is special; since it acts uniformly over tuples. 312 | liftEq :: (S.SVal -> S.SVal -> S.SVal) -> Val 313 | liftEq baseEq = Func Nothing g 314 | where g (Typ _) = return $ Func Nothing g 315 | g v1 = return $ Func Nothing $ \v2 -> return $ Base $ liftEqVal baseEq v1 v2 316 | 317 | -- | Lifting enumFromTo: [x .. y] 318 | sEnumFromTo :: Val 319 | sEnumFromTo = Func Nothing (g []) 320 | where g [x] y = enumList x Nothing y 321 | g args (Typ _) = return $ Func Nothing (g args) 322 | g args v = return $ Func Nothing (g (v:args)) 323 | 324 | -- | Lifting sEnumFromThenTo: [x, y .. z] 325 | sEnumFromThenTo :: Val 326 | sEnumFromThenTo = Func Nothing (g []) 327 | where g [x, y] z = enumList y (Just x) z 328 | g args (Typ _) = return $ Func Nothing (g args) 329 | g args v = return $ Func Nothing (g (v:args)) 330 | 331 | -- | Implement [x .. y] or [x, y .. z]; provided the inputs are concrete 332 | enumList :: Val -> Maybe Val -> Val -> Eval Val 333 | enumList bf mbs bt 334 | | Just bs <- mbs, Just f <- extract bf, Just s <- extract bs, Just t <- extract bt = mkLst $ S.svEnumFromThenTo f (Just s) t 335 | | Just f <- extract bf, Just t <- extract bt = mkLst $ S.svEnumFromThenTo f Nothing t 336 | | True = cantHandle 337 | where extract (Base b) = Just b 338 | extract _ = error $ "SBVPlugin.enumList: Impossible happened: " ++ showSDocUnsafe (ppr (bf, mbs, bt)) 339 | mkLst (Just xs) = return $ Lst $ map Base xs 340 | mkLst _ = cantHandle 341 | cantHandle = do Env{bailOut} <- ask 342 | bailOut "Found unsupported list comprehension expression" 343 | (concat [ [ "From: " ++ showSDocUnsafe (ppr bf) ] 344 | , [ "Then: " ++ showSDocUnsafe (ppr bs) | Just bs <- [mbs]] 345 | , [ "To : " ++ showSDocUnsafe (ppr bt) 346 | , "Kind: " ++ (if isJust mbs then "[x, y .. z]" else "[x .. y]") 347 | , "Hint: The plugin only allows finite comprehensions with concrete boundaries." 348 | ] 349 | ]) 350 | 351 | thToGHC :: (TH.Name, a, b) -> CoreM ((Id, a), b) 352 | thToGHC (n, k, sfn) = do f <- grabTH lookupId n 353 | return ((f, k), sfn) 354 | 355 | -- TODO: Starting with GHC 8.6, we no longer get the names available unless the 356 | -- user code explicitly imports them. See: https://ghc.haskell.org/trac/ghc/ticket/16104 357 | -- I was able to get the workaround it as in below, but it seems really fragile and 358 | -- it also requires me to export the splittable class from the plugin. Surely there 359 | -- must be a better way. 360 | grabTH :: (Name -> CoreM b) -> TH.Name -> CoreM b 361 | grabTH f n = do mbN <- thNameToGhcName n 362 | case mbN of 363 | Just gn -> f gn 364 | Nothing -> f =<< lookInModule (TH.nameModule n) (TH.nameBase n) 365 | where lookInModule Nothing _ = error $ "[SBV] Impossible happened, while trying to locate GHC name for: " ++ show n 366 | lookInModule (Just inModule) bn = do 367 | env@HscEnv{hsc_NC} <- getHscEnv 368 | liftIO $ do r <- findImportedModule env (mkModuleName inModule) NoPkgQual 369 | case r of 370 | Found _ mdl -> lookupNameCache hsc_NC mdl (mkVarOcc bn) 371 | _ -> error $ "[SBV] Impossible happened, can't find " ++ show bn ++ " in module " ++ show inModule 372 | -------------------------------------------------------------------------------- /Data/SBV/Plugin/Analyze.hs: -------------------------------------------------------------------------------- 1 | --------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.SBV.Plugin.Analyze 4 | -- Copyright : (c) Levent Erkok 5 | -- License : BSD3 6 | -- Maintainer : erkokl@gmail.com 7 | -- Stability : experimental 8 | -- 9 | -- Walk the GHC Core, proving theorems/checking safety as they are found 10 | ----------------------------------------------------------------------------- 11 | 12 | {-# LANGUAGE CPP #-} 13 | {-# LANGUAGE NamedFieldPuns #-} 14 | 15 | {-# OPTIONS_GHC -Wall -Werror #-} 16 | 17 | module Data.SBV.Plugin.Analyze (analyzeBind) where 18 | 19 | import GHC.Core.TyCo.Rep as TyCoRep 20 | import GHC.Plugins 21 | import GHC.Tc.Utils.TcType 22 | 23 | import Control.Monad (unless, mplus, zipWithM) 24 | import Control.Monad.Reader 25 | import System.Exit 26 | 27 | import Data.IORef 28 | 29 | import Data.Char (isAlpha, isAlphaNum, isUpper) 30 | import Data.List (intercalate, partition, nub, nubBy, sort, sortOn, isPrefixOf) 31 | import Data.Maybe (listToMaybe, fromMaybe) 32 | 33 | import qualified Data.Map as M 34 | 35 | import qualified Data.SBV as S hiding (proveWithAny) 36 | import qualified Data.SBV.Dynamic as S 37 | import qualified Data.SBV.Internals as S 38 | 39 | import qualified Control.Exception as C 40 | 41 | import Data.SBV.Plugin.Common 42 | import Data.SBV.Plugin.Data 43 | 44 | import Debug.Trace 45 | 46 | -- | Dispatch the analyzer over bindings 47 | analyzeBind :: Config -> CoreBind -> CoreM () 48 | analyzeBind cfg@Config{sbvAnnotation, cfgEnv} = go 49 | where go (NonRec b e) = condProve (b, e) 50 | go (Rec binds) = mapM_ condProve binds 51 | 52 | condProve (b, e) 53 | | not $ null (sbvAnnotation b) 54 | = mapM_ workAnnotated (sbvAnnotation b) 55 | | TyCoRep.TyConApp tc _ <- varType b 56 | , getOccString (tyConName tc) == "Proved" 57 | = liftIO $ prove cfg [] b e 58 | | True 59 | = return () 60 | where workAnnotated (SBV opts) 61 | | Just s <- hasSkip opts 62 | = liftIO $ putStrLn $ "[SBV] " ++ showSpan (flags cfgEnv) (pickSpan [varSpan b]) ++ " Skipping " ++ show (showSDoc (flags cfgEnv) (ppr b)) ++ ": " ++ s 63 | | Uninterpret `elem` opts 64 | = return () 65 | | True 66 | = liftIO $ prove cfg opts b e 67 | hasSkip opts = listToMaybe [s | Skip s <- opts] 68 | 69 | -- | Prove an SBVTheorem 70 | prove :: Config -> [SBVOption] -> Var -> CoreExpr -> IO () 71 | prove cfg@Config{isGHCi} opts b e = do 72 | success <- safely $ proveIt cfg opts b e 73 | unless (success || isGHCi || IgnoreFailure `elem` opts) $ do 74 | putStrLn $ "[SBV] Failed. (Use option '" ++ show IgnoreFailure ++ "' to continue.)" 75 | exitFailure 76 | 77 | -- | Safely execute an action, catching the exceptions, printing and returning False if something goes wrong 78 | safely :: IO Bool -> IO Bool 79 | safely a = a `C.catch` bad 80 | where bad :: C.SomeException -> IO Bool 81 | bad e = do print e 82 | return False 83 | 84 | -- | Returns True if proof went thru 85 | proveIt :: Config -> [SBVOption] -> Var -> CoreExpr -> IO Bool 86 | proveIt cfg@Config{cfgEnv, sbvAnnotation} opts topBind topExpr = do 87 | solverConfigs <- pickSolvers opts 88 | let verbose = Verbose `elem` opts 89 | qCheck = QuickCheck `elem` opts 90 | runProver prop 91 | | qCheck = Left `fmap` S.svQuickCheck prop 92 | | True = Right `fmap` S.proveWithAny [s{S.verbose = verbose} | s <- solverConfigs] prop 93 | topLoc = varSpan topBind 94 | loc = "[SBV] " ++ showSpan (flags cfgEnv) topLoc 95 | slvrTag = ", using " ++ tag ++ "." 96 | where tag = case map (S.name . S.solver) solverConfigs of 97 | [] -> "no solvers" -- can't really happen 98 | [x] -> show x 99 | [x, y] -> show x ++ " and " ++ show y 100 | xs -> intercalate ", " (map show (init xs)) ++ ", and " ++ show (last xs) 101 | putStrLn $ "\n" ++ loc ++ (if qCheck then " QuickChecking " else " Proving ") ++ show (sh topBind) ++ slvrTag 102 | (finalResult, finalUninterps) <- do 103 | finalResult <- runProver (res cfgEnv topLoc) 104 | finalUninterps <- readIORef (rUninterpreted cfgEnv) 105 | return (finalResult, finalUninterps) 106 | case finalResult of 107 | Right (solver, _, sres@(S.ThmResult smtRes)) -> do 108 | let success = case smtRes of 109 | S.Unsatisfiable{} -> True 110 | S.Satisfiable{} -> False 111 | S.Unknown{} -> False -- conservative 112 | S.ProofError{} -> False -- conservative 113 | S.SatExtField{} -> False -- conservative 114 | S.DeltaSat{} -> False -- conservative 115 | putStr $ "[" ++ show solver ++ "] " 116 | print sres 117 | 118 | -- If proof failed and there are uninterpreted non-input values, print a warning; except for "uninteresting" types 119 | let ok t = not . any (eqType t) 120 | eq (a, b) (c, d) = a == c && b `eqType` d 121 | unintVals = filter ((`ok` uninteresting cfgEnv) . snd) $ nubBy eq $ sortOn fst [vt | (vt, (False, _, _)) <- finalUninterps] 122 | unless (success || null unintVals) $ do 123 | let plu | length finalUninterps > 1 = "s:" 124 | | True = ":" 125 | shUI (e, t) = (showSDoc (flags cfgEnv) (ppr (getSrcSpan e)), sh e, sh t) 126 | ls = map shUI unintVals 127 | len1 = maximum (0 : [length s | (s, _, _) <- ls]) 128 | len2 = maximum (0 : [length s | (_, s, _) <- ls]) 129 | pad n s = take n (s ++ repeat ' ') 130 | put (a, b, c) = putStrLn $ " [" ++ pad len1 a ++ "] " ++ pad len2 b ++ " :: " ++ c 131 | putStrLn $ "[SBV] Counter-example might be bogus due to uninterpreted constant" ++ plu 132 | mapM_ put ls 133 | 134 | return success 135 | Left success -> return success 136 | 137 | where debug = Debug `elem` opts 138 | 139 | -- | Sometimes life is hard. Giving up is an option. 140 | cantHandle :: String -> [String] -> Eval a 141 | cantHandle w es = do Env{flags, curLoc} <- ask 142 | let marker = "[SBV] " ++ showSpan flags (pickSpan curLoc) 143 | tag s = marker ++ " " ++ s 144 | tab s = replicate (length marker) ' ' ++ " " ++ s 145 | note = concatMap ("\n" ++) $ tag ("Skipping proof. " ++ w ++ ":") : map tab es 146 | #if MIN_VERSION_base(4,9,0) 147 | errorWithoutStackTrace note 148 | #else 149 | error note 150 | #endif 151 | 152 | res initEnv topLoc = do 153 | v <- runReaderT (symEval topExpr) initEnv { curLoc = [topLoc] 154 | , mbListSize = listToMaybe [n | ListSize n <- opts] 155 | , bailOut = cantHandle 156 | } 157 | case v of 158 | Base r -> return r 159 | r -> error $ "Impossible happened. Final result reduced to a non-base value: " ++ showSDocUnsafe (ppr r) 160 | 161 | tbd :: String -> [String] -> Eval Val 162 | tbd w ws = do Env{bailOut} <- ask 163 | bailOut w ws 164 | 165 | sh o = showSDoc (flags cfgEnv) (ppr o) 166 | 167 | -- Given an alleged theorem, first establish it has the right type, and 168 | -- then go ahead and evaluate it symbolicly after applying it to sufficient 169 | -- number of symbolic arguments 170 | symEval :: CoreExpr -> Eval Val 171 | symEval e = do let (bs, body) = collectBinders (pushLetLambda e) 172 | curEnv@Env{bailOut} <- ask 173 | bodyType <- getType (pickSpan (curLoc curEnv)) (exprType body) 174 | 175 | -- Figure out if there were some unmentioned variables; happens if the top 176 | -- level wasn't fully saturated. 177 | let (extraArgs, finalType) = walk bodyType [] 178 | where walk (KFun d c) sofar = walk c (d:sofar) 179 | walk k sofar = (reverse sofar, k) 180 | 181 | case finalType of 182 | KBase S.KBool -> do -- First collect the named arguments: 183 | argKs <- mapM (\b -> getType (getSrcSpan b) (varType b) >>= \bt -> return (b, bt)) bs 184 | let mkVar ((b, k), mbN) = do sv <- local (\env -> env{curLoc = varSpan b : curLoc env}) 185 | $ mkSym cfg (Just b) (Just (idType b)) k (mbN `mplus` Just (sh b)) 186 | return ((b, k), sv) 187 | bArgs <- mapM mkVar (zip argKs (concat [map Just ns | Names ns <- opts] ++ repeat Nothing)) 188 | 189 | -- Go ahead and run the body symbolically; on bArgs 190 | bRes <- local (\env -> env{envMap = foldr (uncurry M.insert) (envMap env) bArgs}) (go body) 191 | 192 | -- If there are extraArgs; then create symbolics and apply to the result: 193 | let feed [] sres = return sres 194 | feed (k:ks) (Func _ f) = do sv <- mkSym cfg Nothing Nothing k Nothing 195 | f sv >>= feed ks 196 | feed ks v = error $ "Impossible! Left with extra args to apply on a non-function: " ++ sh (ks, v) 197 | 198 | feed extraArgs bRes 199 | 200 | _ -> bailOut "Non-boolean property declaration" (concat [ ["Found : " ++ sh (exprType e)] 201 | , ["Returning: " ++ sh (exprType body) | not (null bs)] 202 | , ["Expected : Bool" ++ if null bs then "" else " result"] 203 | ]) 204 | where -- Sometimes the core has a wrapper let, floated out on top. Float that in. 205 | pushLetLambda (Let b (Lam x bd)) = Lam x (pushLetLambda (Let b bd)) 206 | pushLetLambda o = o 207 | 208 | isUninterpretedBinding :: Var -> Bool 209 | isUninterpretedBinding v = any (Uninterpret `elem`) [opt | SBV opt <- sbvAnnotation v] 210 | 211 | go :: CoreExpr -> Eval Val 212 | go (Tick t e) = local (\envMap -> envMap{curLoc = tickSpan t : curLoc envMap}) $ go e 213 | go e = tgo (exprType e) e 214 | 215 | debugTrace s w 216 | | debug = trace ("--> " ++ s) w 217 | | True = w 218 | 219 | -- Main symbolic evaluator: 220 | tgo :: Type -> CoreExpr -> Eval Val 221 | 222 | tgo t e | debugTrace (sh (e, t)) False = undefined 223 | 224 | tgo t (Var v) = do Env{envMap, coreMap} <- ask 225 | k <- getType (getSrcSpan v) t 226 | case (v, k) `M.lookup` envMap of 227 | Just b -> return b 228 | Nothing -> case v `M.lookup` coreMap of 229 | Just (l, b) -> if isUninterpretedBinding v 230 | then uninterpret False t v 231 | else local (\env -> env{curLoc = l : curLoc env}) $ go b 232 | Nothing -> debugTrace ("Uninterpreting: " ++ sh (v, k, nub $ sort $ map (fst . fst) (M.toList envMap))) 233 | $ uninterpret False t v 234 | 235 | tgo _ (App (Var dataCon) (Lit (LitNumber LitNumInt i))) 236 | | Just con <- isDataConWorkId_maybe dataCon, con `elem` [integerISDataCon, integerIPDataCon, integerINDataCon] 237 | = return $ Base $ S.svInteger S.KUnbounded (v con) 238 | where v con | con == integerINDataCon = -i 239 | | True = i 240 | 241 | -- Other literals 242 | tgo t e@(Lit l) = do Env{machWordSize} <- ask 243 | case l of 244 | LitChar{} -> unint 245 | LitString{} -> unint 246 | LitNullAddr{} -> unint 247 | LitRubbish{} -> unint 248 | LitLabel{} -> unint 249 | LitFloat f -> return $ Base $ S.svFloat (fromRational f) 250 | LitDouble d -> return $ Base $ S.svDouble (fromRational d) 251 | LitNumber lt i -> case lt of 252 | LitNumBigNat -> unint 253 | LitNumInt -> return $ Base $ S.svInteger (S.KBounded True machWordSize) i 254 | LitNumInt8 -> return $ Base $ S.svInteger (S.KBounded True 8 ) i 255 | LitNumInt16 -> return $ Base $ S.svInteger (S.KBounded True 16 ) i 256 | LitNumInt32 -> return $ Base $ S.svInteger (S.KBounded True 32 ) i 257 | LitNumInt64 -> return $ Base $ S.svInteger (S.KBounded True 64 ) i 258 | LitNumWord -> return $ Base $ S.svInteger (S.KBounded False machWordSize) i 259 | LitNumWord8 -> return $ Base $ S.svInteger (S.KBounded False 8 ) i 260 | LitNumWord16 -> return $ Base $ S.svInteger (S.KBounded False 16 ) i 261 | LitNumWord32 -> return $ Base $ S.svInteger (S.KBounded False 32 ) i 262 | LitNumWord64 -> return $ Base $ S.svInteger (S.KBounded False 64 ) i 263 | 264 | where unint = do Env{flags} <- ask 265 | k <- getType noSrcSpan t 266 | nm <- mkValidName (showSDoc flags (ppr e)) 267 | case k of 268 | KBase b -> return $ Base $ S.svUninterpreted b (S.UIGiven nm) (S.UINone True) [] 269 | _ -> error $ "Impossible: The type for literal resulted in non base kind: " ++ sh (e, k) 270 | 271 | tgo tFun orig@App{} = do 272 | reduced <- betaReduce orig 273 | 274 | Env{specials} <- ask 275 | 276 | -- handle specials: Equality, tuples, and lists 277 | let getVar (Var v) = Just v 278 | getVar (Tick _ e) = getVar e 279 | getVar _ = Nothing 280 | 281 | isEq (App (App ev (Type _)) dict) | Just v <- getVar ev, isReallyADictionary dict, Just f <- isEquality specials v = Just f 282 | isEq _ = Nothing 283 | 284 | isTup (Var v) = isTuple specials v 285 | isTup (App f (Type _)) = isTup f 286 | isTup (Tick _ e) = isTup e 287 | isTup _ = Nothing 288 | 289 | isLst (Var v) = isList specials v 290 | isLst (App f (Type _)) = isLst f 291 | isLst (Tick _ e) = isLst e 292 | isLst _ = Nothing 293 | 294 | isSpecial e = isEq e `mplus` isTup e `mplus` isLst e 295 | 296 | case isSpecial reduced of 297 | Just f -> debugTrace ("Special located: " ++ sh (orig, f)) $ return f 298 | Nothing -> case reduced of 299 | 300 | -- special case for exponentiation; there must be a better way to do this 301 | App (App (App (App (Var v) (Type t1)) (Type t2)) dict1) dict2 | isReallyADictionary dict1 && isReallyADictionary dict2 -> do 302 | Env{envMap} <- ask 303 | let vSpan = getSrcSpan v 304 | k1 <- getType vSpan t1 305 | k2 <- getType vSpan t2 306 | let kExp = KFun k1 (KFun k1 k2) 307 | case (v, kExp) `M.lookup` envMap of 308 | Just b -> debugTrace ("Located exp(^): " ++ sh (reduced, kExp)) $ return b 309 | _ -> do Env{coreMap} <- ask 310 | case v `M.lookup` coreMap of 311 | Just (l, e) -> local (\env -> env{curLoc = l : curLoc env}) $ tgo tFun (App (App (App (App e (Type t1)) (Type t2)) dict1) dict2) 312 | Nothing -> tgo tFun (Var v) 313 | 314 | -- special case for split and join; there must be a better way to do this 315 | App (App (App (Var v) (Type t1)) (Type t2)) dict | isReallyADictionary dict -> do 316 | Env{envMap} <- ask 317 | let vSpan = getSrcSpan v 318 | k1 <- getType vSpan t1 319 | k2 <- getType vSpan t2 320 | let kSplit = KFun k1 (KTup [k2, k2]) 321 | kJoin = KFun k1 (KFun k1 k2) 322 | case ((v, kSplit) `M.lookup` envMap, (v, kJoin) `M.lookup` envMap) of 323 | (Just b, _) -> debugTrace ("Located split: " ++ sh (reduced, kSplit)) $ return b 324 | (_, Just b) -> debugTrace ("Located join: " ++ sh (reduced, kJoin)) $ return b 325 | _ -> do Env{coreMap} <- ask 326 | case v `M.lookup` coreMap of 327 | Just (l, e) -> local (\env -> env{curLoc = l : curLoc env}) $ tgo tFun (App (App (App e (Type t1)) (Type t2)) dict) 328 | Nothing -> tgo tFun (Var v) 329 | 330 | App (App (Var v) (Type t)) dict | isReallyADictionary dict -> do 331 | Env{envMap} <- ask 332 | k <- getType (getSrcSpan v) t 333 | case (v, k) `M.lookup` envMap of 334 | Just b -> return b 335 | Nothing -> do Env{coreMap} <- ask 336 | case v `M.lookup` coreMap of 337 | Just (l, e) -> local (\env -> env{curLoc = l : curLoc env}) $ tgo tFun (App (App e (Type t)) dict) 338 | Nothing -> tgo tFun (Var v) 339 | 340 | App (Var v) (Type t) -> do 341 | Env{coreMap} <- ask 342 | case v `M.lookup` coreMap of 343 | Just (l, e) -> local (\env -> env{curLoc = l : curLoc env}) $ tgo tFun (App e (Type t)) 344 | Nothing -> tgo tFun (Var v) 345 | 346 | App (Let (Rec bs) f) a -> go (Let (Rec bs) (App f a)) 347 | 348 | App f e -> do 349 | func <- go f 350 | arg <- go e 351 | case (func, arg) of 352 | (Func _ sf, sv) -> sf sv 353 | _ -> error $ "[SBV] Impossible happened. Got an application with mismatched types: " ++ sh [(f, func), (e, arg)] 354 | 355 | e -> go e 356 | 357 | tgo _ (Lam b body) = do 358 | k <- getType (getSrcSpan b) (varType b) 359 | Env{envMap} <- ask 360 | return $ Func (Just (sh b)) $ \s -> local (\env -> env{envMap = M.insert (b, k) s envMap}) (go body) 361 | 362 | tgo _ (Let (NonRec b e) body) = local (\env -> env{coreMap = M.insert b (varSpan b, e) (coreMap env)}) (go body) 363 | 364 | tgo _ (Let (Rec bs) body) = local (\env -> env{coreMap = foldr (\(b, e) m -> M.insert b (varSpan b, e) m) (coreMap env) bs}) (go body) 365 | 366 | -- Case expressions. We take advantage of the core-invariant that each case alternative 367 | -- is exhaustive; and DEFAULT (if present) is the first alternative. We turn it into a 368 | -- simple if-then-else chain with the last element on the DEFAULT, or whatever comes last. 369 | tgo _ e@(Case ce cBinder caseType alts) 370 | = do sce <- go ce 371 | let caseTooComplicated w [] = tbd ("Unsupported case-expression (" ++ w ++ ")") [sh e] 372 | caseTooComplicated w xs = tbd ("Unsupported case-expression (" ++ w ++ ")") $ [sh e, "While Analyzing:"] ++ xs 373 | 374 | isDefault (Alt DEFAULT _ _) = True 375 | isDefault _ = False 376 | 377 | (defs, nonDefs) = partition isDefault alts 378 | 379 | walk [] = caseTooComplicated "with-non-exhaustive-match" [] -- can't really happen 380 | walk (Alt p bs rhs : rest) = 381 | do -- try to get a "good" location for this alternative, if possible: 382 | let eLoc = case (rhs, bs) of 383 | (Tick t _, _ ) -> tickSpan t 384 | (Var v, _ ) -> varSpan v 385 | (_, b:_) -> varSpan b 386 | _ -> varSpan cBinder 387 | mr <- match eLoc sce p bs 388 | case mr of 389 | Just (m, bs') -> do let result = local (\env -> env{curLoc = eLoc : curLoc env, envMap = foldr (uncurry M.insert) (envMap env) bs'}) $ go rhs 390 | if null rest 391 | then result 392 | else choose (caseTooComplicated "with-complicated-alternatives-during-merging") m result (walk rest) 393 | Nothing -> caseTooComplicated "with-complicated-match" ["MATCH " ++ sh (ce, p), " --> " ++ sh rhs] 394 | 395 | k <- getType (getSrcSpan cBinder) caseType 396 | local (\env -> env{envMap = M.insert (cBinder, k) sce (envMap env)}) $ walk (nonDefs ++ defs) 397 | 398 | where choose bailOut t tb fb = case S.svAsBool t of 399 | Nothing -> do stb <- tb 400 | sfb <- fb 401 | iteVal bailOut t stb sfb 402 | Just True -> tb 403 | Just False -> fb 404 | match :: SrcSpan -> Val -> AltCon -> [Var] -> Eval (Maybe (S.SVal, [((Var, SKind), Val)])) 405 | match sp a c bs = case c of 406 | DEFAULT -> return $ Just (S.svTrue, []) 407 | LitAlt l -> do b <- go (Lit l) 408 | return $ Just (a `eqVal` b, []) 409 | DataAlt dc -> do Env{envMap, destMap} <- ask 410 | k <- getType sp (dataConRepType dc) 411 | let wid = dataConWorkId dc 412 | -- The following lookup in env essentially gets True/False constructors (or other base-values if we add them) 413 | case (wid, k) `M.lookup` envMap of 414 | Just (Base b) -> return $ Just (a `eqVal` Base b, []) 415 | _ -> case wid `M.lookup` destMap of 416 | Nothing -> return Nothing 417 | Just f -> do bts <- mapM (\b -> getType (getSrcSpan b) (varType b) >>= \bt -> return (b, bt)) bs 418 | return $ Just (f a bts) 419 | 420 | tgo t (Cast e c) 421 | = debugTrace ("Going thru a Cast: " ++ sh c) $ tgo t e 422 | 423 | tgo _ (Tick t e) = local (\envMap -> envMap{curLoc = tickSpan t : curLoc envMap}) $ go e 424 | 425 | tgo _ (Type t) 426 | = do Env{curLoc} <- ask 427 | k <- getType (pickSpan curLoc) t 428 | return (Typ k) 429 | 430 | tgo _ e@Coercion{} 431 | = tbd "Unsupported coercion-expression" [sh e] 432 | 433 | isBetaReducable (Type _) = True 434 | isBetaReducable e = isReallyADictionary e 435 | 436 | betaReduce :: CoreExpr -> Eval CoreExpr 437 | betaReduce orig@(App f a) = do 438 | rf <- betaReduce f 439 | if not (isBetaReducable a) 440 | then return (App rf a) 441 | else do let chaseVars :: CoreExpr -> Eval CoreExpr 442 | chaseVars (Var x) = do Env{coreMap} <- ask 443 | case x `M.lookup` coreMap of 444 | Nothing -> return (Var x) 445 | Just (_, b) -> chaseVars b 446 | chaseVars (Tick _ x) = chaseVars x 447 | chaseVars x = return x 448 | func <- chaseVars rf 449 | case func of 450 | Lam x b -> do reduced <- betaReduce $ substExpr (extendSubstList emptySubst [(x, a)]) b 451 | () <- debugTrace ("Beta reduce:\n" ++ sh (orig, reduced)) $ return () 452 | return reduced 453 | _ -> return (App rf a) 454 | betaReduce e = return e 455 | 456 | -- | Is this really a dictionary in disguise? This is a terrible hack, and the ice is thin here. But it seems to work. 457 | -- TODO: Figure out if there's a better way of doing this. Note that this function really does get applications, when 458 | -- those dictionaries are parameterized by others. Think of the case where "Eq [a]" dictionary depends on "Eq a", for 459 | -- instance. In these cases, GHC to produces applications. 460 | isReallyADictionary :: CoreExpr -> Bool 461 | isReallyADictionary (App f _) = isReallyADictionary f 462 | isReallyADictionary (Var v) = "$" `isPrefixOf` unpackFS (occNameFS (occName (varName v))) 463 | isReallyADictionary _ = False 464 | 465 | -- Create a symbolic variable. 466 | mkSym :: Config -> Maybe Var -> Maybe Type -> SKind -> Maybe String -> Eval Val 467 | mkSym Config{cfgEnv} mbBind mbBType = sym 468 | where sh o = showSDoc (flags cfgEnv) (ppr o) 469 | 470 | tinfo k = case mbBType of 471 | Nothing -> "Kind: " ++ sh k 472 | Just t -> "Type: " ++ sh t 473 | 474 | sym (KBase k) nm = do v <- lift $ S.symbolicEnv >>= liftIO . S.svMkSymVar (S.NonQueryVar Nothing) k nm 475 | return (Base v) 476 | 477 | sym (KTup ks) nm = do let ns = map (\i -> (++ ("_" ++ show i)) `fmap` nm) [1 .. length ks] 478 | vs <- zipWithM sym ks ns 479 | return $ Tup vs 480 | 481 | sym (KLst ks) nm = do Env{mbListSize, bailOut} <- ask 482 | ls <- case mbListSize of 483 | Just i -> return i 484 | Nothing -> bailOut "List-argument found, with no size info" 485 | [ "Name: " ++ fromMaybe "anonymous" nm 486 | , tinfo (KLst ks) 487 | , "Hint: Use the \"ListSize\" annotation" 488 | ] 489 | let ns = map (\i -> (++ ("_" ++ show i)) `fmap` nm) [1 .. ls] 490 | vs <- zipWithM sym (replicate ls ks) ns 491 | return (Lst vs) 492 | 493 | sym k@KFun{} nm = case mbBind of 494 | Just v -> uninterpret True (varType v) v 495 | _ -> do Env{bailOut} <- ask 496 | bailOut "Unsupported unnamed higher-order symbolic input" 497 | [ "Name: " ++ fromMaybe "" nm 498 | , tinfo k 499 | , "Hint: Name all higher-order inputs explicitly" 500 | ] 501 | 502 | 503 | -- | Unscale a value. We don't really care about the scale itself, so far as SBV is concerned 504 | unScale :: Scaled a -> a 505 | unScale (Scaled _ a) = a 506 | 507 | -- | Uninterpret an expression 508 | uninterpret :: Bool -> Type -> Var -> Eval Val 509 | uninterpret isInput t var = do 510 | Env{rUninterpreted, flags} <- ask 511 | prevUninterpreted <- liftIO $ readIORef rUninterpreted 512 | case [r | ((v, t'), r) <- prevUninterpreted, var == v && t `eqType` t'] of 513 | (_, _, val):_ -> return val 514 | [] -> do let (tvs, t') = splitForAllTyCoVars t 515 | (args, res) = splitFunTys t' 516 | sp = getSrcSpan var 517 | argKs <- mapM (getType sp . unScale) args 518 | resK <- getType sp res 519 | nm <- mkValidName $ showSDoc flags (ppr var) 520 | body <- walk argKs (nm, resK) [] 521 | let fVal = wrap tvs body 522 | liftIO $ modifyIORef rUninterpreted (((var, t), (isInput, nm, fVal)) :) 523 | return fVal 524 | where walk :: [SKind] -> (String, SKind) -> [Val] -> Eval Val 525 | walk [] (nm, k) args = do Env{mbListSize, bailOut} <- ask 526 | 527 | let mkArg :: Val -> [S.SVal] 528 | mkArg (Base v) = [v] 529 | mkArg (Tup vs) = concatMap mkArg vs 530 | mkArg (Lst vs) = concatMap mkArg vs 531 | mkArg sk = error $ "Not yet supported uninterpreted function with a higher-order argument: " ++ showSDocUnsafe (ppr sk) 532 | 533 | bArgs = concatMap mkArg (reverse args) 534 | 535 | mkRes :: String -> SKind -> Eval [S.SVal] 536 | mkRes n (KBase b) = return [S.svUninterpreted b (S.UIGiven n) (S.UINone True) bArgs] 537 | mkRes n (KTup bs) = concat `fmap` zipWithM mkRes [n ++ "_" ++ show i | i <- [(1 :: Int) .. ]] bs 538 | mkRes n (KLst b) = do ls <- case mbListSize of 539 | Just i -> return i 540 | Nothing -> bailOut "List-argument found in uninterpreted function, with no size info" 541 | ["Hint: Use the \"ListSize\" annotation"] 542 | concat `fmap` zipWithM mkRes [n ++ "_" ++ show i | i <- [(1 :: Int) .. ls]] (repeat b) 543 | mkRes n sk@KFun{} = bailOut "Not yet supported uninterpreted function with a higher-order result" 544 | [ "Name: " ++ n 545 | , "Kind: " ++ showSDocUnsafe (ppr sk) 546 | ] 547 | 548 | res <- mkRes nm k 549 | case map Base res of 550 | [x] -> return x 551 | xs -> return $ Tup xs 552 | 553 | walk (_:ks) nmk args = return $ Func Nothing $ \a -> walk ks nmk (a:args) 554 | 555 | wrap [] f = f 556 | wrap (_:ts) f = Func Nothing $ \_ -> return (wrap ts f) 557 | 558 | -- not every name is good, sigh 559 | mkValidName :: String -> Eval String 560 | mkValidName name = 561 | do Env{rUsedNames} <- ask 562 | usedNames <- liftIO $ readIORef rUsedNames 563 | let unm = unSMT $ genSym usedNames name 564 | liftIO $ modifyIORef rUsedNames (unm :) 565 | return $ escape unm 566 | where genSym bad nm 567 | | nm `elem` bad = hd ("genSym: " ++ nm) [nm' | i <- [(0::Int) ..], let nm' = nm ++ "_" ++ show i, nm' `notElem` bad] 568 | | True = nm 569 | 570 | unSMT nm 571 | | S.isReserved nm 572 | = if not (null nm) && isUpper (hd "unSMT" nm) 573 | then "sbv" ++ nm 574 | else "sbv_" ++ nm 575 | | True 576 | = nm 577 | 578 | escape nm | isAlpha (hd "escape" nm) && all isGood (tl "escape" nm) = nm 579 | | True = "|" ++ map tr nm ++ "|" 580 | 581 | isGood c = isAlphaNum c || c == '_' 582 | tr '|' = '_' 583 | tr '\\' = '_' 584 | tr c = c 585 | 586 | hd :: String -> [a] -> a 587 | hd _ (x:_) = x 588 | hd n [] = error $ "Impossible happened: hd received empty list while running " ++ show n 589 | 590 | tl :: String -> [a] -> [a] 591 | tl _ (_:xs) = xs 592 | tl n [] = error $ "Impossible happened: hd received empty list while running " ++ show n 593 | 594 | -- | Convert a Core type to an SBV Type, retaining functions and tuples 595 | getType :: SrcSpan -> Type -> Eval SKind 596 | getType sp typ = do let (tvs, typ') = splitForAllTyCoVars typ 597 | (args, res) = splitFunTys typ' 598 | argKs <- mapM (getType sp . unScale) args 599 | resK <- getComposite res 600 | return $ wrap tvs $ foldr KFun resK argKs 601 | where wrap ts f = foldr (KFun . mkUninterpreted) f ts 602 | mkUninterpreted v = KBase $ S.KADT (show (occNameFS (occName (varName v)))) [] [] 603 | 604 | -- | Extract tuples, lists, or base kinds 605 | getComposite :: Type -> Eval SKind 606 | getComposite t = case splitTyConApp_maybe t of 607 | Just (k, ts) | isTupleTyCon k -> KTup `fmap` mapM (getType sp) ts 608 | Just (k, [a]) | listTyCon == k -> KLst `fmap` getType sp a 609 | _ -> KBase `fmap` getBaseType t 610 | 611 | -- | Convert a Core type to an SBV kind, if known 612 | -- Otherwise, create an uninterpreted kind, and return that. 613 | getBaseType :: Type -> Eval S.Kind 614 | getBaseType bt = do 615 | Env{tcMap} <- ask 616 | case grabTCs (splitTyConApp_maybe bt) of 617 | Just k -> maybe unknown return (k `M.lookup` tcMap) 618 | _ -> unknown 619 | where -- allow one level of nesting, essentially to support Haskell's 'Ratio Integer' to map to 'SReal' 620 | grabTCs Nothing = Nothing 621 | grabTCs (Just (top, ts)) = do as <- walk ts [] 622 | return $ TCKey (top, as) 623 | walk [] sofar = Just $ reverse sofar 624 | walk (a:as) sofar = case splitTyConApp_maybe a of 625 | Just (ac, []) -> walk as (ac:sofar) 626 | _ -> Nothing 627 | -- Check if we uninterpreted this before; if so, return it, otherwise create a new one 628 | unknown = do Env{flags, rUITypes} <- ask 629 | uiTypes <- liftIO $ readIORef rUITypes 630 | case [k | (bt', k) <- uiTypes, bt `eqType` bt'] of 631 | k:_ -> return k 632 | [] -> do nm <- mkValidName $ showSDoc flags (ppr bt) 633 | let k = S.KADT nm [] [] 634 | liftIO $ modifyIORef rUITypes ((bt, k) :) 635 | return k 636 | 637 | {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} 638 | --------------------------------------------------------------------------------