├── .gitignore ├── CRAPL-LICENSE.txt ├── README.md ├── Setup.hs ├── app └── Main.hs ├── build_data └── BaseDataTypes.hs ├── data ├── PatternsWithParams.hs ├── exact │ ├── Abs.hs │ ├── Abs.hs.expected │ ├── BoolEs.hs │ ├── BoolEs.hs.expected │ ├── BoolInaccessible.hs │ ├── BoolInaccessible.hs.expected │ ├── BooleanGuards.hs │ ├── BooleanGuards.hs.expected │ ├── Bools.hs │ ├── Bools.hs.expected │ ├── ComplicatedInts.hs │ ├── ComplicatedInts.hs.expected │ ├── ConcreteTuples.hs │ ├── ConcreteTuples.hs.expected │ ├── EvalBool.hs │ ├── EvalBool.hs.expected │ ├── FuncGuard.hs │ ├── FuncGuard.hs.expected │ ├── Identity.hs │ ├── Identity.hs.expected │ ├── IntOps.hs │ ├── IntOps.hs.expected │ ├── Integers.hs │ ├── Integers.hs.expected │ ├── Ints.hs │ ├── Ints.hs.expected │ ├── List3Unzip.hs │ ├── List3Unzip.hs.expected │ ├── ListUnzip.hs │ ├── ListUnzip.hs.expected │ ├── Lists.hs │ ├── Lists.hs.expected │ ├── Lists2.hs │ ├── Lists2.hs.expected │ ├── ListsIncomplete.hs │ ├── ListsIncomplete.hs.expected │ ├── MutipleTranslatedGuards.hs │ ├── MutipleTranslatedGuards.hs.expected │ ├── PartialPatternWithVariable.hs │ ├── PartialPatternWithVariable.hs.expected │ ├── PatternWithParameter.hs │ ├── PatternWithParameter.hs.expected │ ├── PatternWithParameterVariableMatch.hs │ ├── PatternWithParameterVariableMatch.hs.expected │ ├── Prime.hs │ ├── Prime.hs.expected │ ├── Redundant.hs │ ├── Redundant.hs.expected │ ├── RedundantGuard.hs │ ├── RedundantGuard.hs.expected │ ├── ReportExample.hs │ ├── ReportExample.hs.expected │ ├── SimpleRedundant.hs │ ├── SimpleRedundant.hs.expected │ ├── SimpleVar.hs │ ├── SimpleVar.hs.expected │ ├── ThreeInts.hs │ ├── ThreeInts.hs.expected │ ├── Tree.hs │ ├── Tree.hs.expected │ ├── TreeEval.hs │ ├── TreeEval.hs.expected │ ├── TreeTraversal.hs │ ├── TreeTraversal.hs.expected │ ├── Trivial.hs │ ├── Trivial.hs.expected │ ├── TrueGuard.hs │ ├── TrueGuard.hs.expected │ ├── Tuples.hs │ ├── Tuples.hs.expected │ ├── TwoInts.hs │ ├── TwoInts.hs.expected │ ├── TypeClass.hs │ ├── TypeClass.hs.expected │ ├── TypeVariable.hs │ ├── TypeVariable.hs.expected │ ├── Variables.hs │ ├── Variables.hs.expected │ ├── Wildcard.hs │ ├── Wildcard.hs.expected │ ├── Word8.hs │ └── Word8.hs.expected └── shouldNotParse │ ├── duplicateSignature.hs │ ├── infixdataconstructor.hs │ ├── missingImplementation.hs │ └── recordDataConstructor.hs ├── hooks.sus ├── makefile ├── patterns.cabal ├── src ├── ClauseProcessing.hs ├── DataDefs.hs ├── Evaluatedness.hs ├── Gatherer.hs ├── Lib.hs ├── OptParse.hs ├── OptParse │ └── Types.hs ├── Oracle.hs ├── Oracle │ └── SBVQueries.hs ├── TH.hs ├── Types.hs └── Util.hs ├── stack.yaml └── test ├── ClauseProcessingSpec.hs ├── GathererSpec.hs ├── LibSpec.hs ├── MainTest.hs ├── Oracle ├── SBVQueriesSpec.hs └── TestUtils.hs ├── OracleSpec.hs └── TestUtils.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # binary 2 | spark 3 | .stack-work 4 | 5 | .HTF/ 6 | 7 | dist 8 | cabal-dev 9 | *.o 10 | *.tix 11 | *.hi 12 | *.chi 13 | *.chs.h 14 | *.dyn_o 15 | *.dyn_hi 16 | .virtualenv 17 | .hpc 18 | .hsenv 19 | .cabal-sandbox/ 20 | cabal.sandbox.config 21 | *.prof 22 | *.aux 23 | *.hp 24 | -------------------------------------------------------------------------------- /CRAPL-LICENSE.txt: -------------------------------------------------------------------------------- 1 | THE CRAPL v0 BETA 1 2 | 3 | 4 | 0. Information about the CRAPL 5 | 6 | If you have questions or concerns about the CRAPL, or you need more 7 | information about this license, please contact: 8 | 9 | Matthew Might 10 | http://matt.might.net/ 11 | 12 | 13 | I. Preamble 14 | 15 | Science thrives on openness. 16 | 17 | In modern science, it is often infeasible to replicate claims without 18 | access to the software underlying those claims. 19 | 20 | Let's all be honest: when scientists write code, aesthetics and 21 | software engineering principles take a back seat to having running, 22 | working code before a deadline. 23 | 24 | So, let's release the ugly. And, let's be proud of that. 25 | 26 | 27 | II. Definitions 28 | 29 | 1. "This License" refers to version 0 beta 1 of the Community 30 | Research and Academic Programming License (the CRAPL). 31 | 32 | 2. "The Program" refers to the medley of source code, shell scripts, 33 | executables, objects, libraries and build files supplied to You, 34 | or these files as modified by You. 35 | 36 | [Any appearance of design in the Program is purely coincidental and 37 | should not in any way be mistaken for evidence of thoughtful 38 | software construction.] 39 | 40 | 3. "You" refers to the person or persons brave and daft enough to use 41 | the Program. 42 | 43 | 4. "The Documentation" refers to the Program. 44 | 45 | 5. "The Author" probably refers to the caffeine-addled graduate 46 | student that got the Program to work moments before a submission 47 | deadline. 48 | 49 | 50 | III. Terms 51 | 52 | 1. By reading this sentence, You have agreed to the terms and 53 | conditions of this License. 54 | 55 | 2. If the Program shows any evidence of having been properly tested 56 | or verified, You will disregard this evidence. 57 | 58 | 3. You agree to hold the Author free from shame, embarrassment or 59 | ridicule for any hacks, kludges or leaps of faith found within the 60 | Program. 61 | 62 | 4. You recognize that any request for support for the Program will be 63 | discarded with extreme prejudice. 64 | 65 | 5. The Author reserves all rights to the Program, except for any 66 | rights granted under any additional licenses attached to the 67 | Program. 68 | 69 | 70 | IV. Permissions 71 | 72 | 1. You are permitted to use the Program to validate published 73 | scientific claims. 74 | 75 | 2. You are permitted to use the Program to validate scientific claims 76 | submitted for peer review, under the condition that You keep 77 | modifications to the Program confidential until those claims have 78 | been published. 79 | 80 | 3. You are permitted to use and/or modify the Program for the 81 | validation of novel scientific claims if You make a good-faith 82 | attempt to notify the Author of Your work and Your claims prior to 83 | submission for publication. 84 | 85 | 4. If You publicly release any claims or data that were supported or 86 | generated by the Program or a modification thereof, in whole or in 87 | part, You will release any inputs supplied to the Program and any 88 | modifications You made to the Progam. This License will be in 89 | effect for the modified program. 90 | 91 | 92 | V. Disclaimer of Warranty 93 | 94 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 95 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 96 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT 97 | WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT 98 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 99 | A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND 100 | PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE 101 | DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR 102 | CORRECTION. 103 | 104 | 105 | VI. Limitation of Liability 106 | 107 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 108 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR 109 | CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 110 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES 111 | ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT 112 | NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR 113 | LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM 114 | TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER 115 | PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 116 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pattern Matching in Haskell 2 | 3 | [Pavel Kalvoda](https://github.com/PJK) 4 | [Tom Sydney Kerckhove](https://github.com/NorfairKing) 5 | 6 | Proof-of-concept implementation of the algorithm proposed by [Karachalias, et al.](http://dl.acm.org/citation.cfm?id=2784748&CFID=628992486&CFTOKEN=93477105). 7 | 8 | Detects common issues with pattern definitions on the structural level and integrates the [Z3 SMT solver](https://github.com/Z3Prover/z3) to provide a semantic insight into guards. 9 | 10 | ## Build/Install/Run 11 | 12 | To build/install, you will need a copy of the repository: 13 | 14 | ``` 15 | git clone https://github.com/PJK/paps-pattern-matching 16 | ``` 17 | 18 | 19 | ### Code 20 | 21 | The code for the tool is written in Haskell and built with `stack`/`cabal`. 22 | A `stack.yaml` is provided. 23 | 24 | Run `stack build` to build, `stack install` to install and `stack test` to run the tests. 25 | 26 | To run the code as intended, you will need the `z3` SMT solver. 27 | The code will work without problems if you don't have `z3`, but you may not get the desired result. 28 | 29 | ## Usage 30 | 31 | As `patterns --help` will tell you: 32 | 33 | ``` 34 | Usage: patterns COMMAND [-d|--debug] 35 | Analyse pattern matching by Pavel Kalvoda and Tom Sydney Kerckhove 36 | 37 | Available options: 38 | -h,--help Show this help text 39 | -d,--debug turn on debug information 40 | 41 | Available commands: 42 | analyze Analyze and present recommendations 43 | evaluatedness Present evaluatedness 44 | dump-results Dump analysis results for testing 45 | ``` 46 | 47 | ## How to read results 48 | 49 | ### Recommendations 50 | 51 | There are three kinds of recommendations that you may get. 52 | 53 | 54 | #### Non-exhaustive pattern 55 | 56 | ##### Simple patterns 57 | 58 | Example code: `data/exact/Bools.hs` 59 | 60 | ``` Haskell 61 | and :: Bool -> Bool -> Bool 62 | and True True = True 63 | and False _ = False 64 | ``` 65 | 66 | As you can see, there is a clause missing. 67 | 68 | ``` 69 | $ patterns analyze data/exact/Bools.hs 70 | In function and: 71 | The patterns may not be exhaustive, the following clauses are missing: 72 | and True False 73 | ``` 74 | 75 | This means that, to complete the function's definition, you may have to add another clause, namely `and True False`. 76 | Because the tool only approximates, it is possible to be recommended to complete a function that already has exhaustive patterns in practice. 77 | 78 | ##### Patterns with guards 79 | 80 | The tool also works for programs with guards. 81 | 82 | Example code: `data/exact/Abs.hs` 83 | 84 | ``` Haskell 85 | abs :: Int -> Int 86 | abs x 87 | | x < 0 = - x 88 | | x > 0 = x 89 | ``` 90 | 91 | This function is undefined when `x` equals `0`, and the tool figures this out: 92 | 93 | ``` 94 | $ patterns analyze data/exact/Abs.hs 95 | 96 | In function abs: 97 | The patterns may not be exhaustive, the following clauses are missing: 98 | abs ~a 99 | Constraints: 100 | ~f == False 101 | ~f == ~a > 0 102 | ~c == False 103 | ~c == ~a < 0 104 | 105 | Satisfiable. Model: 106 | ~f = False :: Bool 107 | ~a = 0 :: Integer 108 | ~c = False :: Bool 109 | ``` 110 | 111 | Note: the tilde's in front of the variables `~a`, etc just indicate that this is a fresh variable introduced in the analysis. 112 | They are simply variables like any other, but they make sure we don't accidentally use the same variable twice in the analysis. 113 | 114 | This should be read as follows: 115 | To complete the function, you may need to add a clause of the form `abs ~a`. 116 | Here are the constraints under which this clause would be selected and here is a model that shows one specific situation in which that would in fact happen. 117 | 118 | #### Redundant clause 119 | 120 | Example code: `data/exact/SimpleRedundant.hs` 121 | 122 | ``` Haskell 123 | g :: Bool -> Int 124 | g True = 1 125 | g True = 2 126 | g False = 3 127 | ``` 128 | 129 | As you can see, the second clause is redundant. 130 | 131 | ``` 132 | $ patterns analyze data/exact/SimpleRedundant.hs 133 | In function g: 134 | The following clause is redundant: 135 | g True 136 | ``` 137 | 138 | This means that this clause can never be selected for evaluation, and its removal will not alter the semantics of the function. 139 | Even though the tool approximates, it overapproximates, so when it tells you that a clause is redundant, that is guaranteed to be true. 140 | It is then safe to remove this clause. 141 | 142 | #### Inaccessible Right-hand side 143 | 144 | Example code: `data/exact/ReportExample.hs` 145 | 146 | ``` Haskell 147 | f :: Bool -> Bool -> Int 148 | f _ True = 1 149 | f True True = 2 150 | f _ False = 3 151 | ``` 152 | 153 | The second clause has an inaccessible right-hand side. 154 | 155 | ``` 156 | $ patterns analyze data/exact/ReportExample.hs 157 | In function f: 158 | The following clause has an inaccesible right hand side: 159 | f True True 160 | ``` 161 | 162 | This means that this clause will never be selected for evaluation. 163 | Even though the tool approximates, it overapproximates, so when it tells you that a clause has an inaccessible right-hand side, that is guaranteed to be true. 164 | It is then safe to remove this clause. 165 | 166 | ### Evaluatedness 167 | 168 | Example code: `data/exact/Tree.hs` 169 | 170 | ``` Haskell 171 | data Tree a = Fork a (Tree a) (Tree a) | Nil 172 | 173 | func :: Tree a -> Int 174 | func Nil = 1 175 | func (Fork _ Nil Nil) = 2 176 | func (Fork _ Nil _) = 3 177 | func (Fork _ _ Nil) = 4 178 | ``` 179 | 180 | When we ask the tool to compute the evaluatedness of this function, we get the following output: 181 | 182 | ``` 183 | Evaluatedness of function "func" 184 | 185 | func ~a 186 | ~a: ~a 187 | 188 | func (Fork ~e ~f ~g) 189 | (Fork ~e ~f ~g): (Fork _ ~f _) 190 | 191 | func (Fork ~e Nil ~g) 192 | (Fork ~e Nil ~g): (Fork _ Nil ~g) 193 | 194 | func (Fork ~e (Fork ~k ~l ~m) ~g) 195 | (Fork ~e (Fork ~k ~l ~m) ~g): (Fork _ (Fork _ _ _) ~g) 196 | ``` 197 | 198 | While this looks very complicated at first, it is actually not so bad to read once you understand the format. 199 | 200 | The first line of every 'paragraph' is something of the form ` `. 201 | This line indicates the form of the input and should be read as "When the function `function` is evaluated with the arguments ``,". 202 | The next lines then complete this sentence: `: ` should be read as ` will be evaluated such that ``. 203 | 204 | Concretely, for the example above this becomes: 205 | 206 | ``` 207 | func ~a 208 | ~a: ~a 209 | ``` 210 | 211 | "When the input to `func` is an arbitrary argument, which we will call `~a`, 212 | `~a`'s first constructor is evaluated." 213 | 214 | ``` 215 | func (Fork ~e ~f ~g) 216 | (Fork ~e ~f ~g): (Fork _ ~f _) 217 | ``` 218 | 219 | "When the input to `func` is of the form `(Fork ~e ~f ~g)` where `~e`, `~f` and `~g` are arbitrary expressions, 220 | `~e` and `~g` remain untouched but `~f`'s first constructor will be evaluated." 221 | 222 | etc... 223 | 224 | ## Development 225 | 226 | Should you want to contribute, please install the git hooks as provided to ensure (some standard of) code quality. 227 | 228 | ``` 229 | spark deploy hooks.sus 230 | ``` 231 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = patterns 7 | -------------------------------------------------------------------------------- /build_data/BaseDataTypes.hs: -------------------------------------------------------------------------------- 1 | module BaseDataTypes where 2 | 3 | data Bool = False | True 4 | data Ordering = LT | EQ | GT 5 | type String = [Char] 6 | 7 | data Maybe a = Nothing | Just a 8 | deriving (Eq, Ord) 9 | 10 | data Either a b = Left a | Right b 11 | deriving (Eq, Ord, Read, Show, Typeable) 12 | -------------------------------------------------------------------------------- /data/PatternsWithParams.hs: -------------------------------------------------------------------------------- 1 | module PatternsWithParams where 2 | 3 | data Maybe a = Just a | None 4 | data MyBool = True | False 5 | 6 | unwrap :: Maybe a -> MyBool -> a 7 | unwrap None _ = error "kaboom" 8 | unwrap (Just val) True = val 9 | -- Missing Just False -------------------------------------------------------------------------------- /data/exact/Abs.hs: -------------------------------------------------------------------------------- 1 | module Abs where 2 | 3 | abs :: Int -> Int 4 | abs x 5 | | x < 0 = - x 6 | | x > 0 = x 7 | 8 | -------------------------------------------------------------------------------- /data/exact/Abs.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "abs", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~f == False\n ~f == ~a > 0\n ~c == False\n ~c == ~a < 0\n\nSatisfiable. Model:\n ~f = False :: Bool\n ~a = 0 :: Integer\n ~c = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "abs", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ] 55 | ] 56 | ] 57 | ] 58 | ] 59 | } 60 | -------------------------------------------------------------------------------- /data/exact/BoolEs.hs: -------------------------------------------------------------------------------- 1 | module BoolEs where 2 | 3 | -- Not exhaustive 4 | f :: Bool -> Bool -> Int 5 | f x y 6 | | x && y = 1 7 | | x || y = 2 8 | -------------------------------------------------------------------------------- /data/exact/BoolEs.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | }, 16 | { 17 | "tag": "VariablePattern", 18 | "contents": "~b" 19 | } 20 | ], 21 | "Constraints:\n ~g == False\n ~g == ~a || ~b\n ~d == False\n ~d == ~a && ~b\n\nSatisfiable. Model:\n ~g = False :: Bool\n ~a = False :: Bool\n ~b = False :: Bool\n ~d = False :: Bool\n" 22 | ] 23 | ] 24 | } 25 | ] 26 | ], 27 | [ 28 | [ 29 | "f", 30 | [ 31 | [ 32 | [ 33 | { 34 | "tag": "VariablePattern", 35 | "contents": "~a" 36 | }, 37 | { 38 | "tag": "VariablePattern", 39 | "contents": "~b" 40 | } 41 | ], 42 | [ 43 | { 44 | "tag": "WildcardPattern", 45 | "contents": [] 46 | }, 47 | { 48 | "tag": "WildcardPattern", 49 | "contents": [] 50 | } 51 | ] 52 | ], 53 | [ 54 | [ 55 | { 56 | "tag": "VariablePattern", 57 | "contents": "~a" 58 | }, 59 | { 60 | "tag": "VariablePattern", 61 | "contents": "~b" 62 | } 63 | ], 64 | [ 65 | { 66 | "tag": "WildcardPattern", 67 | "contents": [] 68 | }, 69 | { 70 | "tag": "WildcardPattern", 71 | "contents": [] 72 | } 73 | ] 74 | ] 75 | ] 76 | ] 77 | ] 78 | ] 79 | } 80 | -------------------------------------------------------------------------------- /data/exact/BoolInaccessible.hs: -------------------------------------------------------------------------------- 1 | func :: Bool -> Bool -> Int 2 | func _ False = 1 3 | func True False = 2 4 | func _ _ = 3 5 | -------------------------------------------------------------------------------- /data/exact/BoolInaccessible.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "func", 7 | { 8 | "tag": "InaccessibleRhs", 9 | "contents": [ 10 | { 11 | "tag": "ConstructorPattern", 12 | "contents": [ 13 | "True", 14 | [] 15 | ] 16 | }, 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "False", 21 | [] 22 | ] 23 | } 24 | ] 25 | } 26 | ] 27 | ], 28 | [ 29 | [ 30 | "func", 31 | [ 32 | [ 33 | [ 34 | { 35 | "tag": "VariablePattern", 36 | "contents": "~a" 37 | }, 38 | { 39 | "tag": "VariablePattern", 40 | "contents": "~b" 41 | } 42 | ], 43 | [ 44 | { 45 | "tag": "WildcardPattern", 46 | "contents": [] 47 | }, 48 | { 49 | "tag": "VariablePattern", 50 | "contents": "~b" 51 | } 52 | ] 53 | ], 54 | [ 55 | [ 56 | { 57 | "tag": "VariablePattern", 58 | "contents": "~a" 59 | }, 60 | { 61 | "tag": "ConstructorPattern", 62 | "contents": [ 63 | "True", 64 | [] 65 | ] 66 | } 67 | ], 68 | [ 69 | { 70 | "tag": "VariablePattern", 71 | "contents": "~a" 72 | }, 73 | { 74 | "tag": "ConstructorPattern", 75 | "contents": [ 76 | "True", 77 | [] 78 | ] 79 | } 80 | ] 81 | ] 82 | ] 83 | ] 84 | ] 85 | ] 86 | } 87 | -------------------------------------------------------------------------------- /data/exact/BooleanGuards.hs: -------------------------------------------------------------------------------- 1 | module BooleanGuards where 2 | 3 | bguard :: Bool -> Int 4 | bguard x 5 | | x = 0 6 | | not x = 1 7 | | otherwise = 2 -- redundant 8 | -- Exhaustive 9 | 10 | 11 | -------------------------------------------------------------------------------- /data/exact/BooleanGuards.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "bguard", 7 | { 8 | "tag": "Redundant", 9 | "contents": [ 10 | { 11 | "tag": "WildcardPattern", 12 | "contents": [] 13 | }, 14 | { 15 | "tag": "GuardPattern", 16 | "contents": [ 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "True", 21 | [] 22 | ] 23 | }, 24 | { 25 | "tag": "BExp", 26 | "contents": { 27 | "tag": "Otherwise", 28 | "contents": [] 29 | } 30 | } 31 | ] 32 | } 33 | ] 34 | } 35 | ] 36 | ], 37 | [ 38 | [ 39 | "bguard", 40 | [ 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ], 55 | [ 56 | [ 57 | { 58 | "tag": "VariablePattern", 59 | "contents": "~a" 60 | } 61 | ], 62 | [ 63 | { 64 | "tag": "WildcardPattern", 65 | "contents": [] 66 | } 67 | ] 68 | ], 69 | [ 70 | [ 71 | { 72 | "tag": "VariablePattern", 73 | "contents": "~a" 74 | } 75 | ], 76 | [ 77 | { 78 | "tag": "WildcardPattern", 79 | "contents": [] 80 | } 81 | ] 82 | ] 83 | ] 84 | ] 85 | ] 86 | ] 87 | } 88 | -------------------------------------------------------------------------------- /data/exact/Bools.hs: -------------------------------------------------------------------------------- 1 | and :: Bool -> Bool -> Bool 2 | and True True = True 3 | and False _ = False 4 | -------------------------------------------------------------------------------- /data/exact/Bools.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "and", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "True", 16 | [] 17 | ] 18 | }, 19 | { 20 | "tag": "ConstructorPattern", 21 | "contents": [ 22 | "False", 23 | [] 24 | ] 25 | } 26 | ], 27 | "" 28 | ] 29 | ] 30 | } 31 | ] 32 | ], 33 | [ 34 | [ 35 | "and", 36 | [ 37 | [ 38 | [ 39 | { 40 | "tag": "VariablePattern", 41 | "contents": "~a" 42 | }, 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~b" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "VariablePattern", 51 | "contents": "~a" 52 | }, 53 | { 54 | "tag": "WildcardPattern", 55 | "contents": [] 56 | } 57 | ] 58 | ], 59 | [ 60 | [ 61 | { 62 | "tag": "ConstructorPattern", 63 | "contents": [ 64 | "True", 65 | [] 66 | ] 67 | }, 68 | { 69 | "tag": "VariablePattern", 70 | "contents": "~b" 71 | } 72 | ], 73 | [ 74 | { 75 | "tag": "ConstructorPattern", 76 | "contents": [ 77 | "True", 78 | [] 79 | ] 80 | }, 81 | { 82 | "tag": "VariablePattern", 83 | "contents": "~b" 84 | } 85 | ] 86 | ] 87 | ] 88 | ] 89 | ] 90 | ] 91 | } 92 | -------------------------------------------------------------------------------- /data/exact/ComplicatedInts.hs: -------------------------------------------------------------------------------- 1 | comp :: Int -> Int 2 | comp x 3 | | x > 5 = 1 4 | | x < 0 = 1 5 | comp x 6 | | x < 3 = 1 7 | | x > 3 = 1 8 | 9 | -------------------------------------------------------------------------------- /data/exact/ComplicatedInts.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "comp", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~l == False\n ~l == ~a > 3\n ~i == False\n ~i == ~a < 3\n ~f == False\n ~f == ~a < 0\n ~c == False\n ~c == ~a > 5\n\nSatisfiable. Model:\n ~l = False :: Bool\n ~a = 3 :: Integer\n ~i = False :: Bool\n ~f = False :: Bool\n ~c = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "comp", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ], 55 | [ 56 | [ 57 | { 58 | "tag": "VariablePattern", 59 | "contents": "~a" 60 | } 61 | ], 62 | [ 63 | { 64 | "tag": "WildcardPattern", 65 | "contents": [] 66 | } 67 | ] 68 | ], 69 | [ 70 | [ 71 | { 72 | "tag": "VariablePattern", 73 | "contents": "~a" 74 | } 75 | ], 76 | [ 77 | { 78 | "tag": "WildcardPattern", 79 | "contents": [] 80 | } 81 | ] 82 | ] 83 | ] 84 | ] 85 | ] 86 | ] 87 | } 88 | -------------------------------------------------------------------------------- /data/exact/ConcreteTuples.hs: -------------------------------------------------------------------------------- 1 | module ConcreteTuples where 2 | 3 | quadrupleAnd :: (Bool, Bool, Bool, Bool) -> Bool 4 | quadrupleAnd (True, True, True, True) = True 5 | quadrupleAnd (False, _, _, _) = False 6 | quadrupleAnd (_, False, _, _) = False 7 | quadrupleAnd (_, _, False, _) = False 8 | -- T, T, T, F is missing -------------------------------------------------------------------------------- /data/exact/EvalBool.hs: -------------------------------------------------------------------------------- 1 | module EvalBool where 2 | 3 | func :: Bool -> Bool -> Int 4 | func _ False = 1 5 | func True False = 2 6 | func _ _ = 3 -------------------------------------------------------------------------------- /data/exact/EvalBool.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "func", 7 | { 8 | "tag": "InaccessibleRhs", 9 | "contents": [ 10 | { 11 | "tag": "ConstructorPattern", 12 | "contents": [ 13 | "True", 14 | [] 15 | ] 16 | }, 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "False", 21 | [] 22 | ] 23 | } 24 | ] 25 | } 26 | ] 27 | ], 28 | [ 29 | [ 30 | "func", 31 | [ 32 | [ 33 | [ 34 | { 35 | "tag": "VariablePattern", 36 | "contents": "~a" 37 | }, 38 | { 39 | "tag": "VariablePattern", 40 | "contents": "~b" 41 | } 42 | ], 43 | [ 44 | { 45 | "tag": "WildcardPattern", 46 | "contents": [] 47 | }, 48 | { 49 | "tag": "VariablePattern", 50 | "contents": "~b" 51 | } 52 | ] 53 | ], 54 | [ 55 | [ 56 | { 57 | "tag": "VariablePattern", 58 | "contents": "~a" 59 | }, 60 | { 61 | "tag": "ConstructorPattern", 62 | "contents": [ 63 | "True", 64 | [] 65 | ] 66 | } 67 | ], 68 | [ 69 | { 70 | "tag": "VariablePattern", 71 | "contents": "~a" 72 | }, 73 | { 74 | "tag": "ConstructorPattern", 75 | "contents": [ 76 | "True", 77 | [] 78 | ] 79 | } 80 | ] 81 | ] 82 | ] 83 | ] 84 | ] 85 | ] 86 | } 87 | -------------------------------------------------------------------------------- /data/exact/FuncGuard.hs: -------------------------------------------------------------------------------- 1 | module FuncGuard where 2 | 3 | isPrimeOrSmall :: Int -> Bool 4 | isPrimeOrSmall x 5 | | isPrime x && x < 10 = True 6 | | not (isPrime x) = False 7 | 8 | -------------------------------------------------------------------------------- /data/exact/FuncGuard.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "isPrimeOrSmall", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~f == False\n ~f == not (isPrime x)\n ~c == False\n ~c == isPrime x && ~a < 10\n\nSatisfiable. Model:\n ~f = False :: Bool\n (isPrime x) = True :: Bool\n ~c = False :: Bool\n isPrime x = False :: Bool\n ~a = 9 :: Integer\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "isPrimeOrSmall", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ] 55 | ] 56 | ] 57 | ] 58 | ] 59 | } 60 | -------------------------------------------------------------------------------- /data/exact/Identity.hs: -------------------------------------------------------------------------------- 1 | module Identity where 2 | 3 | id :: a -> a 4 | id x = x -------------------------------------------------------------------------------- /data/exact/Identity.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "id", 8 | [] 9 | ] 10 | ] 11 | ] 12 | } 13 | -------------------------------------------------------------------------------- /data/exact/IntOps.hs: -------------------------------------------------------------------------------- 1 | module IntOps where 2 | 3 | -- Not exhaustive and the first clause is redundant because it's always false 4 | f :: Int -> Int 5 | f x | 2 `div` 1 == 1 = 1 6 | 7 | -- Second is redundant 8 | g :: Int -> Int 9 | g x | 2 `rem` 3 == 2 = 1 10 | | otherwise = 2 11 | 12 | -- Same but with infix 13 | h :: Int -> Int 14 | h x | 2 `rem` 3 == 2 = 1 15 | | otherwise = 2 16 | -------------------------------------------------------------------------------- /data/exact/IntOps.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "WildcardPattern", 14 | "contents": [] 15 | } 16 | ], 17 | "Constraints:\n ~c == False\n ~c == 2 `div` 1 == 1\n\nSatisfiable. Model:\n ~c = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ], 22 | [ 23 | "f", 24 | { 25 | "tag": "Redundant", 26 | "contents": [ 27 | { 28 | "tag": "WildcardPattern", 29 | "contents": [] 30 | }, 31 | { 32 | "tag": "GuardPattern", 33 | "contents": [ 34 | { 35 | "tag": "ConstructorPattern", 36 | "contents": [ 37 | "True", 38 | [] 39 | ] 40 | }, 41 | { 42 | "tag": "BExp", 43 | "contents": { 44 | "tag": "IntBoolOp", 45 | "contents": [ 46 | "IntEQ", 47 | { 48 | "tag": "IntOp", 49 | "contents": [ 50 | "IntDiv", 51 | { 52 | "tag": "IntLit", 53 | "contents": 2 54 | }, 55 | { 56 | "tag": "IntLit", 57 | "contents": 1 58 | } 59 | ] 60 | }, 61 | { 62 | "tag": "IntLit", 63 | "contents": 1 64 | } 65 | ] 66 | } 67 | } 68 | ] 69 | } 70 | ] 71 | } 72 | ], 73 | [ 74 | "g", 75 | { 76 | "tag": "Redundant", 77 | "contents": [ 78 | { 79 | "tag": "WildcardPattern", 80 | "contents": [] 81 | }, 82 | { 83 | "tag": "GuardPattern", 84 | "contents": [ 85 | { 86 | "tag": "ConstructorPattern", 87 | "contents": [ 88 | "True", 89 | [] 90 | ] 91 | }, 92 | { 93 | "tag": "BExp", 94 | "contents": { 95 | "tag": "Otherwise", 96 | "contents": [] 97 | } 98 | } 99 | ] 100 | } 101 | ] 102 | } 103 | ], 104 | [ 105 | "h", 106 | { 107 | "tag": "Redundant", 108 | "contents": [ 109 | { 110 | "tag": "WildcardPattern", 111 | "contents": [] 112 | }, 113 | { 114 | "tag": "GuardPattern", 115 | "contents": [ 116 | { 117 | "tag": "ConstructorPattern", 118 | "contents": [ 119 | "True", 120 | [] 121 | ] 122 | }, 123 | { 124 | "tag": "BExp", 125 | "contents": { 126 | "tag": "Otherwise", 127 | "contents": [] 128 | } 129 | } 130 | ] 131 | } 132 | ] 133 | } 134 | ] 135 | ], 136 | [ 137 | [ 138 | "f", 139 | [ 140 | [ 141 | [ 142 | { 143 | "tag": "VariablePattern", 144 | "contents": "~a" 145 | } 146 | ], 147 | [ 148 | { 149 | "tag": "WildcardPattern", 150 | "contents": [] 151 | } 152 | ] 153 | ] 154 | ] 155 | ], 156 | [ 157 | "g", 158 | [ 159 | [ 160 | [ 161 | { 162 | "tag": "VariablePattern", 163 | "contents": "~a" 164 | } 165 | ], 166 | [ 167 | { 168 | "tag": "WildcardPattern", 169 | "contents": [] 170 | } 171 | ] 172 | ], 173 | [ 174 | [ 175 | { 176 | "tag": "VariablePattern", 177 | "contents": "~a" 178 | } 179 | ], 180 | [ 181 | { 182 | "tag": "WildcardPattern", 183 | "contents": [] 184 | } 185 | ] 186 | ] 187 | ] 188 | ], 189 | [ 190 | "h", 191 | [ 192 | [ 193 | [ 194 | { 195 | "tag": "VariablePattern", 196 | "contents": "~a" 197 | } 198 | ], 199 | [ 200 | { 201 | "tag": "WildcardPattern", 202 | "contents": [] 203 | } 204 | ] 205 | ], 206 | [ 207 | [ 208 | { 209 | "tag": "VariablePattern", 210 | "contents": "~a" 211 | } 212 | ], 213 | [ 214 | { 215 | "tag": "WildcardPattern", 216 | "contents": [] 217 | } 218 | ] 219 | ] 220 | ] 221 | ] 222 | ] 223 | ] 224 | } 225 | -------------------------------------------------------------------------------- /data/exact/Integers.hs: -------------------------------------------------------------------------------- 1 | module Integers where 2 | 3 | odd :: Int -> Bool 4 | odd 1 5 | | 1 + 1 > 4 = True -- redundant 6 | | otherwise = False 7 | odd 2 = False 8 | -- Infinite set of uncovered constructors 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /data/exact/Integers.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "odd", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~la == False\n ~la == ~a == 2\n ~r == False\n ~r == ~a == 1\n ~f == False\n ~f == ~a == 1\n\nSatisfiable. Model:\n ~la = False :: Bool\n ~a = 3 :: Integer\n ~r = False :: Bool\n ~f = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ], 22 | [ 23 | "odd", 24 | { 25 | "tag": "Redundant", 26 | "contents": [ 27 | { 28 | "tag": "LiteralPattern", 29 | "contents": [ 30 | "Signless", 31 | { 32 | "tag": "Int", 33 | "contents": 1 34 | } 35 | ] 36 | }, 37 | { 38 | "tag": "GuardPattern", 39 | "contents": [ 40 | { 41 | "tag": "ConstructorPattern", 42 | "contents": [ 43 | "True", 44 | [] 45 | ] 46 | }, 47 | { 48 | "tag": "BExp", 49 | "contents": { 50 | "tag": "IntBoolOp", 51 | "contents": [ 52 | "IntGT", 53 | { 54 | "tag": "IntOp", 55 | "contents": [ 56 | "IntPlus", 57 | { 58 | "tag": "IntLit", 59 | "contents": 1 60 | }, 61 | { 62 | "tag": "IntLit", 63 | "contents": 1 64 | } 65 | ] 66 | }, 67 | { 68 | "tag": "IntLit", 69 | "contents": 4 70 | } 71 | ] 72 | } 73 | } 74 | ] 75 | } 76 | ] 77 | } 78 | ] 79 | ], 80 | [ 81 | [ 82 | "odd", 83 | [ 84 | [ 85 | [ 86 | { 87 | "tag": "VariablePattern", 88 | "contents": "~a" 89 | } 90 | ], 91 | [ 92 | { 93 | "tag": "WildcardPattern", 94 | "contents": [] 95 | } 96 | ] 97 | ], 98 | [ 99 | [ 100 | { 101 | "tag": "VariablePattern", 102 | "contents": "~a" 103 | } 104 | ], 105 | [ 106 | { 107 | "tag": "WildcardPattern", 108 | "contents": [] 109 | } 110 | ] 111 | ], 112 | [ 113 | [ 114 | { 115 | "tag": "VariablePattern", 116 | "contents": "~a" 117 | } 118 | ], 119 | [ 120 | { 121 | "tag": "WildcardPattern", 122 | "contents": [] 123 | } 124 | ] 125 | ], 126 | [ 127 | [ 128 | { 129 | "tag": "VariablePattern", 130 | "contents": "~a" 131 | } 132 | ], 133 | [ 134 | { 135 | "tag": "WildcardPattern", 136 | "contents": [] 137 | } 138 | ] 139 | ], 140 | [ 141 | [ 142 | { 143 | "tag": "VariablePattern", 144 | "contents": "~a" 145 | } 146 | ], 147 | [ 148 | { 149 | "tag": "WildcardPattern", 150 | "contents": [] 151 | } 152 | ] 153 | ], 154 | [ 155 | [ 156 | { 157 | "tag": "VariablePattern", 158 | "contents": "~a" 159 | } 160 | ], 161 | [ 162 | { 163 | "tag": "WildcardPattern", 164 | "contents": [] 165 | } 166 | ] 167 | ], 168 | [ 169 | [ 170 | { 171 | "tag": "VariablePattern", 172 | "contents": "~a" 173 | } 174 | ], 175 | [ 176 | { 177 | "tag": "WildcardPattern", 178 | "contents": [] 179 | } 180 | ] 181 | ], 182 | [ 183 | [ 184 | { 185 | "tag": "VariablePattern", 186 | "contents": "~a" 187 | } 188 | ], 189 | [ 190 | { 191 | "tag": "WildcardPattern", 192 | "contents": [] 193 | } 194 | ] 195 | ], 196 | [ 197 | [ 198 | { 199 | "tag": "VariablePattern", 200 | "contents": "~a" 201 | } 202 | ], 203 | [ 204 | { 205 | "tag": "WildcardPattern", 206 | "contents": [] 207 | } 208 | ] 209 | ], 210 | [ 211 | [ 212 | { 213 | "tag": "VariablePattern", 214 | "contents": "~a" 215 | } 216 | ], 217 | [ 218 | { 219 | "tag": "WildcardPattern", 220 | "contents": [] 221 | } 222 | ] 223 | ] 224 | ] 225 | ] 226 | ] 227 | ] 228 | } 229 | -------------------------------------------------------------------------------- /data/exact/Ints.hs: -------------------------------------------------------------------------------- 1 | module Ints where 2 | 3 | -- Missing > 0 4 | f :: Int -> Int 5 | f 0 = 1 6 | f x | x < 0 = 2 7 | 8 | -- Exhaustive 9 | g :: Int -> Int 10 | g 0 = 1 11 | g x | x < 0 = 2 12 | | x > 0 = 3 13 | -------------------------------------------------------------------------------- /data/exact/Ints.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~i == False\n ~i == ~a < 0\n ~e == False\n ~e == ~a == 0\n\nSatisfiable. Model:\n ~i = False :: Bool\n ~a = 1 :: Integer\n ~e = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "f", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ] 55 | ] 56 | ], 57 | [ 58 | "g", 59 | [ 60 | [ 61 | [ 62 | { 63 | "tag": "VariablePattern", 64 | "contents": "~a" 65 | } 66 | ], 67 | [ 68 | { 69 | "tag": "WildcardPattern", 70 | "contents": [] 71 | } 72 | ] 73 | ], 74 | [ 75 | [ 76 | { 77 | "tag": "VariablePattern", 78 | "contents": "~a" 79 | } 80 | ], 81 | [ 82 | { 83 | "tag": "WildcardPattern", 84 | "contents": [] 85 | } 86 | ] 87 | ], 88 | [ 89 | [ 90 | { 91 | "tag": "VariablePattern", 92 | "contents": "~a" 93 | } 94 | ], 95 | [ 96 | { 97 | "tag": "WildcardPattern", 98 | "contents": [] 99 | } 100 | ] 101 | ] 102 | ] 103 | ] 104 | ] 105 | ] 106 | } 107 | -------------------------------------------------------------------------------- /data/exact/List3Unzip.hs: -------------------------------------------------------------------------------- 1 | module ListUnzip where 2 | 3 | unzip :: [a] -> [(a, a, a)] 4 | unzip [] = [] 5 | unzip (x:y:z:zz) = (x, y, z):unzip zz 6 | -- List of length 1 and 2 missing 7 | 8 | -------------------------------------------------------------------------------- /data/exact/List3Unzip.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "unzip", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "InfixConstructorPattern", 14 | "contents": [ 15 | { 16 | "tag": "WildcardPattern", 17 | "contents": [] 18 | }, 19 | ":", 20 | { 21 | "tag": "InfixConstructorPattern", 22 | "contents": [ 23 | { 24 | "tag": "WildcardPattern", 25 | "contents": [] 26 | }, 27 | ":", 28 | { 29 | "tag": "EmptyListPattern", 30 | "contents": [] 31 | } 32 | ] 33 | } 34 | ] 35 | } 36 | ], 37 | "" 38 | ], 39 | [ 40 | [ 41 | { 42 | "tag": "InfixConstructorPattern", 43 | "contents": [ 44 | { 45 | "tag": "WildcardPattern", 46 | "contents": [] 47 | }, 48 | ":", 49 | { 50 | "tag": "EmptyListPattern", 51 | "contents": [] 52 | } 53 | ] 54 | } 55 | ], 56 | "" 57 | ] 58 | ] 59 | } 60 | ] 61 | ], 62 | [ 63 | [ 64 | "unzip", 65 | [ 66 | [ 67 | [ 68 | { 69 | "tag": "VariablePattern", 70 | "contents": "~a" 71 | } 72 | ], 73 | [ 74 | { 75 | "tag": "VariablePattern", 76 | "contents": "~a" 77 | } 78 | ] 79 | ], 80 | [ 81 | [ 82 | { 83 | "tag": "EmptyListPattern", 84 | "contents": [] 85 | } 86 | ], 87 | [ 88 | { 89 | "tag": "EmptyListPattern", 90 | "contents": [] 91 | } 92 | ] 93 | ], 94 | [ 95 | [ 96 | { 97 | "tag": "InfixConstructorPattern", 98 | "contents": [ 99 | { 100 | "tag": "VariablePattern", 101 | "contents": "~b" 102 | }, 103 | ":", 104 | { 105 | "tag": "VariablePattern", 106 | "contents": "~c" 107 | } 108 | ] 109 | } 110 | ], 111 | [ 112 | { 113 | "tag": "InfixConstructorPattern", 114 | "contents": [ 115 | { 116 | "tag": "WildcardPattern", 117 | "contents": [] 118 | }, 119 | ":", 120 | { 121 | "tag": "VariablePattern", 122 | "contents": "~c" 123 | } 124 | ] 125 | } 126 | ] 127 | ], 128 | [ 129 | [ 130 | { 131 | "tag": "InfixConstructorPattern", 132 | "contents": [ 133 | { 134 | "tag": "VariablePattern", 135 | "contents": "~b" 136 | }, 137 | ":", 138 | { 139 | "tag": "InfixConstructorPattern", 140 | "contents": [ 141 | { 142 | "tag": "VariablePattern", 143 | "contents": "~l" 144 | }, 145 | ":", 146 | { 147 | "tag": "VariablePattern", 148 | "contents": "~m" 149 | } 150 | ] 151 | } 152 | ] 153 | } 154 | ], 155 | [ 156 | { 157 | "tag": "InfixConstructorPattern", 158 | "contents": [ 159 | { 160 | "tag": "WildcardPattern", 161 | "contents": [] 162 | }, 163 | ":", 164 | { 165 | "tag": "InfixConstructorPattern", 166 | "contents": [ 167 | { 168 | "tag": "WildcardPattern", 169 | "contents": [] 170 | }, 171 | ":", 172 | { 173 | "tag": "VariablePattern", 174 | "contents": "~m" 175 | } 176 | ] 177 | } 178 | ] 179 | } 180 | ] 181 | ] 182 | ] 183 | ] 184 | ] 185 | ] 186 | } 187 | -------------------------------------------------------------------------------- /data/exact/ListUnzip.hs: -------------------------------------------------------------------------------- 1 | module ListUnzip where 2 | 3 | unzip :: [a] -> [(a, a)] 4 | unzip [] = [] 5 | unzip (x:y:zz) = (x, y):unzip zz 6 | -- List of odd length missing 7 | 8 | -------------------------------------------------------------------------------- /data/exact/ListUnzip.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "unzip", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "InfixConstructorPattern", 14 | "contents": [ 15 | { 16 | "tag": "WildcardPattern", 17 | "contents": [] 18 | }, 19 | ":", 20 | { 21 | "tag": "EmptyListPattern", 22 | "contents": [] 23 | } 24 | ] 25 | } 26 | ], 27 | "" 28 | ] 29 | ] 30 | } 31 | ] 32 | ], 33 | [ 34 | [ 35 | "unzip", 36 | [ 37 | [ 38 | [ 39 | { 40 | "tag": "VariablePattern", 41 | "contents": "~a" 42 | } 43 | ], 44 | [ 45 | { 46 | "tag": "VariablePattern", 47 | "contents": "~a" 48 | } 49 | ] 50 | ], 51 | [ 52 | [ 53 | { 54 | "tag": "EmptyListPattern", 55 | "contents": [] 56 | } 57 | ], 58 | [ 59 | { 60 | "tag": "EmptyListPattern", 61 | "contents": [] 62 | } 63 | ] 64 | ], 65 | [ 66 | [ 67 | { 68 | "tag": "InfixConstructorPattern", 69 | "contents": [ 70 | { 71 | "tag": "VariablePattern", 72 | "contents": "~b" 73 | }, 74 | ":", 75 | { 76 | "tag": "VariablePattern", 77 | "contents": "~c" 78 | } 79 | ] 80 | } 81 | ], 82 | [ 83 | { 84 | "tag": "InfixConstructorPattern", 85 | "contents": [ 86 | { 87 | "tag": "WildcardPattern", 88 | "contents": [] 89 | }, 90 | ":", 91 | { 92 | "tag": "VariablePattern", 93 | "contents": "~c" 94 | } 95 | ] 96 | } 97 | ] 98 | ] 99 | ] 100 | ] 101 | ] 102 | ] 103 | } 104 | -------------------------------------------------------------------------------- /data/exact/Lists.hs: -------------------------------------------------------------------------------- 1 | module Lists where 2 | 3 | length :: [Int] -> Int 4 | length [_, _, _] = 3 5 | length (x:xs) = 1 + (length xs) 6 | length [] = 0 7 | -------------------------------------------------------------------------------- /data/exact/Lists2.hs: -------------------------------------------------------------------------------- 1 | module Lists where 2 | 3 | -- Not exhaustive, 2 patterns missing 4 | f :: [a] -> Int 5 | f (x:y:xs) = 2 + (length xs) 6 | 7 | -- Not exhaustive, lengths greater than 2 missing, one pattern. 8 | g :: [a] -> Int 9 | g [] = 0 10 | g [x] = 1 11 | g [x, y] = 2 12 | 13 | -------------------------------------------------------------------------------- /data/exact/ListsIncomplete.hs: -------------------------------------------------------------------------------- 1 | module ListsIncomplete where 2 | 3 | length :: [a] -> Int 4 | length [_] = 1 5 | length (x:xs) = 1 + (length xs) 6 | 7 | -------------------------------------------------------------------------------- /data/exact/ListsIncomplete.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "length", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "EmptyListPattern", 14 | "contents": [] 15 | } 16 | ], 17 | "" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "length", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "VariablePattern", 37 | "contents": "~a" 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "InfixConstructorPattern", 45 | "contents": [ 46 | { 47 | "tag": "VariablePattern", 48 | "contents": "~h" 49 | }, 50 | ":", 51 | { 52 | "tag": "VariablePattern", 53 | "contents": "~i" 54 | } 55 | ] 56 | } 57 | ], 58 | [ 59 | { 60 | "tag": "InfixConstructorPattern", 61 | "contents": [ 62 | { 63 | "tag": "WildcardPattern", 64 | "contents": [] 65 | }, 66 | ":", 67 | { 68 | "tag": "VariablePattern", 69 | "contents": "~i" 70 | } 71 | ] 72 | } 73 | ] 74 | ], 75 | [ 76 | [ 77 | { 78 | "tag": "InfixConstructorPattern", 79 | "contents": [ 80 | { 81 | "tag": "VariablePattern", 82 | "contents": "~h" 83 | }, 84 | ":", 85 | { 86 | "tag": "EmptyListPattern", 87 | "contents": [] 88 | } 89 | ] 90 | } 91 | ], 92 | [ 93 | { 94 | "tag": "InfixConstructorPattern", 95 | "contents": [ 96 | { 97 | "tag": "WildcardPattern", 98 | "contents": [] 99 | }, 100 | ":", 101 | { 102 | "tag": "EmptyListPattern", 103 | "contents": [] 104 | } 105 | ] 106 | } 107 | ] 108 | ] 109 | ] 110 | ] 111 | ] 112 | ] 113 | } 114 | -------------------------------------------------------------------------------- /data/exact/MutipleTranslatedGuards.hs: -------------------------------------------------------------------------------- 1 | module MutipleTranslatedGuards where 2 | 3 | succ :: Int -> Int -> Bool 4 | succ 0 1 = True 5 | succ 1 2 = True 6 | succ 2 3 = True 7 | succ _ _ = False -------------------------------------------------------------------------------- /data/exact/MutipleTranslatedGuards.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "succ", 8 | [ 9 | [ 10 | [ 11 | { 12 | "tag": "VariablePattern", 13 | "contents": "~a" 14 | }, 15 | { 16 | "tag": "VariablePattern", 17 | "contents": "~b" 18 | } 19 | ], 20 | [ 21 | { 22 | "tag": "WildcardPattern", 23 | "contents": [] 24 | }, 25 | { 26 | "tag": "WildcardPattern", 27 | "contents": [] 28 | } 29 | ] 30 | ], 31 | [ 32 | [ 33 | { 34 | "tag": "VariablePattern", 35 | "contents": "~a" 36 | }, 37 | { 38 | "tag": "VariablePattern", 39 | "contents": "~b" 40 | } 41 | ], 42 | [ 43 | { 44 | "tag": "WildcardPattern", 45 | "contents": [] 46 | }, 47 | { 48 | "tag": "WildcardPattern", 49 | "contents": [] 50 | } 51 | ] 52 | ], 53 | [ 54 | [ 55 | { 56 | "tag": "VariablePattern", 57 | "contents": "~a" 58 | }, 59 | { 60 | "tag": "VariablePattern", 61 | "contents": "~b" 62 | } 63 | ], 64 | [ 65 | { 66 | "tag": "WildcardPattern", 67 | "contents": [] 68 | }, 69 | { 70 | "tag": "WildcardPattern", 71 | "contents": [] 72 | } 73 | ] 74 | ], 75 | [ 76 | [ 77 | { 78 | "tag": "VariablePattern", 79 | "contents": "~a" 80 | }, 81 | { 82 | "tag": "VariablePattern", 83 | "contents": "~b" 84 | } 85 | ], 86 | [ 87 | { 88 | "tag": "WildcardPattern", 89 | "contents": [] 90 | }, 91 | { 92 | "tag": "WildcardPattern", 93 | "contents": [] 94 | } 95 | ] 96 | ], 97 | [ 98 | [ 99 | { 100 | "tag": "VariablePattern", 101 | "contents": "~a" 102 | }, 103 | { 104 | "tag": "VariablePattern", 105 | "contents": "~b" 106 | } 107 | ], 108 | [ 109 | { 110 | "tag": "WildcardPattern", 111 | "contents": [] 112 | }, 113 | { 114 | "tag": "WildcardPattern", 115 | "contents": [] 116 | } 117 | ] 118 | ], 119 | [ 120 | [ 121 | { 122 | "tag": "VariablePattern", 123 | "contents": "~a" 124 | }, 125 | { 126 | "tag": "VariablePattern", 127 | "contents": "~b" 128 | } 129 | ], 130 | [ 131 | { 132 | "tag": "WildcardPattern", 133 | "contents": [] 134 | }, 135 | { 136 | "tag": "WildcardPattern", 137 | "contents": [] 138 | } 139 | ] 140 | ], 141 | [ 142 | [ 143 | { 144 | "tag": "VariablePattern", 145 | "contents": "~a" 146 | }, 147 | { 148 | "tag": "VariablePattern", 149 | "contents": "~b" 150 | } 151 | ], 152 | [ 153 | { 154 | "tag": "WildcardPattern", 155 | "contents": [] 156 | }, 157 | { 158 | "tag": "WildcardPattern", 159 | "contents": [] 160 | } 161 | ] 162 | ], 163 | [ 164 | [ 165 | { 166 | "tag": "VariablePattern", 167 | "contents": "~a" 168 | }, 169 | { 170 | "tag": "VariablePattern", 171 | "contents": "~b" 172 | } 173 | ], 174 | [ 175 | { 176 | "tag": "WildcardPattern", 177 | "contents": [] 178 | }, 179 | { 180 | "tag": "WildcardPattern", 181 | "contents": [] 182 | } 183 | ] 184 | ], 185 | [ 186 | [ 187 | { 188 | "tag": "VariablePattern", 189 | "contents": "~a" 190 | }, 191 | { 192 | "tag": "VariablePattern", 193 | "contents": "~b" 194 | } 195 | ], 196 | [ 197 | { 198 | "tag": "WildcardPattern", 199 | "contents": [] 200 | }, 201 | { 202 | "tag": "WildcardPattern", 203 | "contents": [] 204 | } 205 | ] 206 | ], 207 | [ 208 | [ 209 | { 210 | "tag": "VariablePattern", 211 | "contents": "~a" 212 | }, 213 | { 214 | "tag": "VariablePattern", 215 | "contents": "~b" 216 | } 217 | ], 218 | [ 219 | { 220 | "tag": "WildcardPattern", 221 | "contents": [] 222 | }, 223 | { 224 | "tag": "WildcardPattern", 225 | "contents": [] 226 | } 227 | ] 228 | ], 229 | [ 230 | [ 231 | { 232 | "tag": "VariablePattern", 233 | "contents": "~a" 234 | }, 235 | { 236 | "tag": "VariablePattern", 237 | "contents": "~b" 238 | } 239 | ], 240 | [ 241 | { 242 | "tag": "WildcardPattern", 243 | "contents": [] 244 | }, 245 | { 246 | "tag": "WildcardPattern", 247 | "contents": [] 248 | } 249 | ] 250 | ], 251 | [ 252 | [ 253 | { 254 | "tag": "VariablePattern", 255 | "contents": "~a" 256 | }, 257 | { 258 | "tag": "VariablePattern", 259 | "contents": "~b" 260 | } 261 | ], 262 | [ 263 | { 264 | "tag": "WildcardPattern", 265 | "contents": [] 266 | }, 267 | { 268 | "tag": "WildcardPattern", 269 | "contents": [] 270 | } 271 | ] 272 | ], 273 | [ 274 | [ 275 | { 276 | "tag": "VariablePattern", 277 | "contents": "~a" 278 | }, 279 | { 280 | "tag": "VariablePattern", 281 | "contents": "~b" 282 | } 283 | ], 284 | [ 285 | { 286 | "tag": "WildcardPattern", 287 | "contents": [] 288 | }, 289 | { 290 | "tag": "WildcardPattern", 291 | "contents": [] 292 | } 293 | ] 294 | ], 295 | [ 296 | [ 297 | { 298 | "tag": "VariablePattern", 299 | "contents": "~a" 300 | }, 301 | { 302 | "tag": "VariablePattern", 303 | "contents": "~b" 304 | } 305 | ], 306 | [ 307 | { 308 | "tag": "WildcardPattern", 309 | "contents": [] 310 | }, 311 | { 312 | "tag": "WildcardPattern", 313 | "contents": [] 314 | } 315 | ] 316 | ] 317 | ] 318 | ] 319 | ] 320 | ] 321 | } 322 | -------------------------------------------------------------------------------- /data/exact/PartialPatternWithVariable.hs: -------------------------------------------------------------------------------- 1 | module PartialPatternWithVariable where 2 | 3 | data MyTrinary = A | B | C 4 | 5 | data MyMaybe = Sum MyTrinary | Nope 6 | 7 | partialExtract :: MyMaybe -> MyMaybe -> MyTrinary 8 | partialExtract (Sum C) (Sum A) = A 9 | partialExtract (Sum x) y = B 10 | partialExtract Nope (Sum C) = B 11 | 12 | -------------------------------------------------------------------------------- /data/exact/PatternWithParameter.hs: -------------------------------------------------------------------------------- 1 | module PatternWithParameter where 2 | 3 | data MyTrinary = A | B | C 4 | 5 | data MyMaybe = Sum MyTrinary | Nope 6 | 7 | extract :: MyMaybe -> MyTrinary 8 | extract (Sum C) = A 9 | extract (Sum A) = B 10 | 11 | -------------------------------------------------------------------------------- /data/exact/PatternWithParameter.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "extract", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "Sum", 16 | [ 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "B", 21 | [] 22 | ] 23 | } 24 | ] 25 | ] 26 | } 27 | ], 28 | "" 29 | ], 30 | [ 31 | [ 32 | { 33 | "tag": "ConstructorPattern", 34 | "contents": [ 35 | "Nope", 36 | [] 37 | ] 38 | } 39 | ], 40 | "" 41 | ] 42 | ] 43 | } 44 | ] 45 | ], 46 | [ 47 | [ 48 | "extract", 49 | [ 50 | [ 51 | [ 52 | { 53 | "tag": "VariablePattern", 54 | "contents": "~a" 55 | } 56 | ], 57 | [ 58 | { 59 | "tag": "VariablePattern", 60 | "contents": "~a" 61 | } 62 | ] 63 | ], 64 | [ 65 | [ 66 | { 67 | "tag": "ConstructorPattern", 68 | "contents": [ 69 | "Sum", 70 | [ 71 | { 72 | "tag": "VariablePattern", 73 | "contents": "~e" 74 | } 75 | ] 76 | ] 77 | } 78 | ], 79 | [ 80 | { 81 | "tag": "ConstructorPattern", 82 | "contents": [ 83 | "Sum", 84 | [ 85 | { 86 | "tag": "VariablePattern", 87 | "contents": "~e" 88 | } 89 | ] 90 | ] 91 | } 92 | ] 93 | ] 94 | ] 95 | ] 96 | ] 97 | ] 98 | } 99 | -------------------------------------------------------------------------------- /data/exact/PatternWithParameterVariableMatch.hs: -------------------------------------------------------------------------------- 1 | module PatternWithParameterVariableMatch where 2 | 3 | data MyTrinary = A | B | C 4 | 5 | extract :: Maybe MyTritary -> Maybe MyTritary -> MyTrinary 6 | extract (Just C) (Just A) = A 7 | extract (Just x) y = B -- This should catch Just A, Just B, _ 8 | extract Nothing x = B 9 | 10 | 11 | partialExtract :: Maybe MyTritary -> Maybe MyTritary -> MyTrinary 12 | partialExtract (Just C) (Just A) = A 13 | partialExtract (Just x) y = B -- This should catch Just A, Just B, _ 14 | partialExtract Nothing (Just C) = B 15 | 16 | 17 | -------------------------------------------------------------------------------- /data/exact/Prime.hs: -------------------------------------------------------------------------------- 1 | f :: Int -> Int 2 | f x | 5 > 1 && isPrime 2 = 1 3 | -------------------------------------------------------------------------------- /data/exact/Prime.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "WildcardPattern", 14 | "contents": [] 15 | } 16 | ], 17 | "Constraints:\n ~c == False\n ~c == 5 > 1 && isPrime 2\n\nSatisfiable. Model:\n ~c = False :: Bool\n isPrime 2 = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "f", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ] 41 | ] 42 | ] 43 | ] 44 | ] 45 | } 46 | -------------------------------------------------------------------------------- /data/exact/Redundant.hs: -------------------------------------------------------------------------------- 1 | module Redundant where 2 | 3 | func :: Bool -> Int 4 | func False = 1 5 | func False = 2 6 | -------------------------------------------------------------------------------- /data/exact/Redundant.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "func", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "True", 16 | [] 17 | ] 18 | } 19 | ], 20 | "" 21 | ] 22 | ] 23 | } 24 | ], 25 | [ 26 | "func", 27 | { 28 | "tag": "Redundant", 29 | "contents": [ 30 | { 31 | "tag": "ConstructorPattern", 32 | "contents": [ 33 | "False", 34 | [] 35 | ] 36 | } 37 | ] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | "func", 44 | [ 45 | [ 46 | [ 47 | { 48 | "tag": "VariablePattern", 49 | "contents": "~a" 50 | } 51 | ], 52 | [ 53 | { 54 | "tag": "VariablePattern", 55 | "contents": "~a" 56 | } 57 | ] 58 | ] 59 | ] 60 | ] 61 | ] 62 | ] 63 | } 64 | -------------------------------------------------------------------------------- /data/exact/RedundantGuard.hs: -------------------------------------------------------------------------------- 1 | module RedundantGuard where 2 | 3 | 4 | func :: Int -> Int 5 | func x 6 | | x == 0 = 0 7 | | x > 0 = 1 8 | | x < 0 = -1 9 | | x == 3 = 3 -------------------------------------------------------------------------------- /data/exact/RedundantGuard.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "func", 7 | { 8 | "tag": "Redundant", 9 | "contents": [ 10 | { 11 | "tag": "WildcardPattern", 12 | "contents": [] 13 | }, 14 | { 15 | "tag": "GuardPattern", 16 | "contents": [ 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "True", 21 | [] 22 | ] 23 | }, 24 | { 25 | "tag": "BExp", 26 | "contents": { 27 | "tag": "IntBoolOp", 28 | "contents": [ 29 | "IntEQ", 30 | { 31 | "tag": "IntVar", 32 | "contents": "x" 33 | }, 34 | { 35 | "tag": "IntLit", 36 | "contents": 3 37 | } 38 | ] 39 | } 40 | } 41 | ] 42 | } 43 | ] 44 | } 45 | ] 46 | ], 47 | [ 48 | [ 49 | "func", 50 | [ 51 | [ 52 | [ 53 | { 54 | "tag": "VariablePattern", 55 | "contents": "~a" 56 | } 57 | ], 58 | [ 59 | { 60 | "tag": "WildcardPattern", 61 | "contents": [] 62 | } 63 | ] 64 | ], 65 | [ 66 | [ 67 | { 68 | "tag": "VariablePattern", 69 | "contents": "~a" 70 | } 71 | ], 72 | [ 73 | { 74 | "tag": "WildcardPattern", 75 | "contents": [] 76 | } 77 | ] 78 | ], 79 | [ 80 | [ 81 | { 82 | "tag": "VariablePattern", 83 | "contents": "~a" 84 | } 85 | ], 86 | [ 87 | { 88 | "tag": "WildcardPattern", 89 | "contents": [] 90 | } 91 | ] 92 | ], 93 | [ 94 | [ 95 | { 96 | "tag": "VariablePattern", 97 | "contents": "~a" 98 | } 99 | ], 100 | [ 101 | { 102 | "tag": "WildcardPattern", 103 | "contents": [] 104 | } 105 | ] 106 | ] 107 | ] 108 | ] 109 | ] 110 | ] 111 | } 112 | -------------------------------------------------------------------------------- /data/exact/ReportExample.hs: -------------------------------------------------------------------------------- 1 | f :: Bool -> Bool -> Int 2 | f _ True = 1 3 | f True True = 2 4 | f _ False = 3 5 | -------------------------------------------------------------------------------- /data/exact/ReportExample.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "InaccessibleRhs", 9 | "contents": [ 10 | { 11 | "tag": "ConstructorPattern", 12 | "contents": [ 13 | "True", 14 | [] 15 | ] 16 | }, 17 | { 18 | "tag": "ConstructorPattern", 19 | "contents": [ 20 | "True", 21 | [] 22 | ] 23 | } 24 | ] 25 | } 26 | ] 27 | ], 28 | [ 29 | [ 30 | "f", 31 | [ 32 | [ 33 | [ 34 | { 35 | "tag": "VariablePattern", 36 | "contents": "~a" 37 | }, 38 | { 39 | "tag": "VariablePattern", 40 | "contents": "~b" 41 | } 42 | ], 43 | [ 44 | { 45 | "tag": "WildcardPattern", 46 | "contents": [] 47 | }, 48 | { 49 | "tag": "VariablePattern", 50 | "contents": "~b" 51 | } 52 | ] 53 | ], 54 | [ 55 | [ 56 | { 57 | "tag": "VariablePattern", 58 | "contents": "~a" 59 | }, 60 | { 61 | "tag": "ConstructorPattern", 62 | "contents": [ 63 | "False", 64 | [] 65 | ] 66 | } 67 | ], 68 | [ 69 | { 70 | "tag": "VariablePattern", 71 | "contents": "~a" 72 | }, 73 | { 74 | "tag": "ConstructorPattern", 75 | "contents": [ 76 | "False", 77 | [] 78 | ] 79 | } 80 | ] 81 | ] 82 | ] 83 | ] 84 | ] 85 | ] 86 | } 87 | -------------------------------------------------------------------------------- /data/exact/SimpleRedundant.hs: -------------------------------------------------------------------------------- 1 | g :: Bool -> Int 2 | g True = 1 3 | g True = 2 4 | g False = 3 5 | -------------------------------------------------------------------------------- /data/exact/SimpleRedundant.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "g", 7 | { 8 | "tag": "Redundant", 9 | "contents": [ 10 | { 11 | "tag": "ConstructorPattern", 12 | "contents": [ 13 | "True", 14 | [] 15 | ] 16 | } 17 | ] 18 | } 19 | ] 20 | ], 21 | [ 22 | [ 23 | "g", 24 | [ 25 | [ 26 | [ 27 | { 28 | "tag": "VariablePattern", 29 | "contents": "~a" 30 | } 31 | ], 32 | [ 33 | { 34 | "tag": "VariablePattern", 35 | "contents": "~a" 36 | } 37 | ] 38 | ] 39 | ] 40 | ] 41 | ] 42 | ] 43 | } 44 | -------------------------------------------------------------------------------- /data/exact/SimpleVar.hs: -------------------------------------------------------------------------------- 1 | module SimpleVar where 2 | 3 | data MyTrinary = A | B | C 4 | fun :: MyTrinary -> MyTrinary -> MyTrinary 5 | fun x A = A 6 | fun B B = A 7 | 8 | -------------------------------------------------------------------------------- /data/exact/SimpleVar.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "fun", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "A", 16 | [] 17 | ] 18 | }, 19 | { 20 | "tag": "ConstructorPattern", 21 | "contents": [ 22 | "B", 23 | [] 24 | ] 25 | } 26 | ], 27 | "" 28 | ], 29 | [ 30 | [ 31 | { 32 | "tag": "ConstructorPattern", 33 | "contents": [ 34 | "C", 35 | [] 36 | ] 37 | }, 38 | { 39 | "tag": "ConstructorPattern", 40 | "contents": [ 41 | "B", 42 | [] 43 | ] 44 | } 45 | ], 46 | "" 47 | ], 48 | [ 49 | [ 50 | { 51 | "tag": "ConstructorPattern", 52 | "contents": [ 53 | "A", 54 | [] 55 | ] 56 | }, 57 | { 58 | "tag": "ConstructorPattern", 59 | "contents": [ 60 | "C", 61 | [] 62 | ] 63 | } 64 | ], 65 | "" 66 | ], 67 | [ 68 | [ 69 | { 70 | "tag": "ConstructorPattern", 71 | "contents": [ 72 | "B", 73 | [] 74 | ] 75 | }, 76 | { 77 | "tag": "ConstructorPattern", 78 | "contents": [ 79 | "C", 80 | [] 81 | ] 82 | } 83 | ], 84 | "" 85 | ], 86 | [ 87 | [ 88 | { 89 | "tag": "ConstructorPattern", 90 | "contents": [ 91 | "C", 92 | [] 93 | ] 94 | }, 95 | { 96 | "tag": "ConstructorPattern", 97 | "contents": [ 98 | "C", 99 | [] 100 | ] 101 | } 102 | ], 103 | "" 104 | ] 105 | ] 106 | } 107 | ] 108 | ], 109 | [ 110 | [ 111 | "fun", 112 | [ 113 | [ 114 | [ 115 | { 116 | "tag": "VariablePattern", 117 | "contents": "~a" 118 | }, 119 | { 120 | "tag": "VariablePattern", 121 | "contents": "~b" 122 | } 123 | ], 124 | [ 125 | { 126 | "tag": "WildcardPattern", 127 | "contents": [] 128 | }, 129 | { 130 | "tag": "VariablePattern", 131 | "contents": "~b" 132 | } 133 | ] 134 | ], 135 | [ 136 | [ 137 | { 138 | "tag": "VariablePattern", 139 | "contents": "~a" 140 | }, 141 | { 142 | "tag": "ConstructorPattern", 143 | "contents": [ 144 | "B", 145 | [] 146 | ] 147 | } 148 | ], 149 | [ 150 | { 151 | "tag": "VariablePattern", 152 | "contents": "~a" 153 | }, 154 | { 155 | "tag": "ConstructorPattern", 156 | "contents": [ 157 | "B", 158 | [] 159 | ] 160 | } 161 | ] 162 | ], 163 | [ 164 | [ 165 | { 166 | "tag": "VariablePattern", 167 | "contents": "~a" 168 | }, 169 | { 170 | "tag": "ConstructorPattern", 171 | "contents": [ 172 | "C", 173 | [] 174 | ] 175 | } 176 | ], 177 | [ 178 | { 179 | "tag": "VariablePattern", 180 | "contents": "~a" 181 | }, 182 | { 183 | "tag": "ConstructorPattern", 184 | "contents": [ 185 | "C", 186 | [] 187 | ] 188 | } 189 | ] 190 | ] 191 | ] 192 | ] 193 | ] 194 | ] 195 | } 196 | -------------------------------------------------------------------------------- /data/exact/ThreeInts.hs: -------------------------------------------------------------------------------- 1 | f :: Int -> Int -> Int 2 | f 0 1 = 1 3 | f 1 2 = 2 4 | -------------------------------------------------------------------------------- /data/exact/ThreeInts.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | }, 16 | { 17 | "tag": "WildcardPattern", 18 | "contents": [] 19 | } 20 | ], 21 | "Constraints:\n ~x == False\n ~x == ~a == 1\n ~h == False\n ~h == ~a == 0\n\nSatisfiable. Model:\n ~x = False :: Bool\n ~a = 2 :: Integer\n ~h = False :: Bool\n" 22 | ], 23 | [ 24 | [ 25 | { 26 | "tag": "VariablePattern", 27 | "contents": "~a" 28 | }, 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~b" 32 | } 33 | ], 34 | "Constraints:\n ~z == False\n ~z == ~b == 2\n ~x == True\n ~x == ~a == 1\n ~h == False\n ~h == ~a == 0\n\nSatisfiable. Model:\n ~z = False :: Bool\n ~b = 3 :: Integer\n ~x = True :: Bool\n ~a = 1 :: Integer\n ~h = False :: Bool\n" 35 | ], 36 | [ 37 | [ 38 | { 39 | "tag": "VariablePattern", 40 | "contents": "~a" 41 | }, 42 | { 43 | "tag": "VariablePattern", 44 | "contents": "~b" 45 | } 46 | ], 47 | "Constraints:\n ~ba == False\n ~ba == ~a == 1\n ~j == False\n ~j == ~b == 1\n ~h == True\n ~h == ~a == 0\n\nSatisfiable. Model:\n ~ba = False :: Bool\n ~a = 0 :: Integer\n ~j = False :: Bool\n ~b = 2 :: Integer\n ~h = True :: Bool\n" 48 | ] 49 | ] 50 | } 51 | ] 52 | ], 53 | [ 54 | [ 55 | "f", 56 | [ 57 | [ 58 | [ 59 | { 60 | "tag": "VariablePattern", 61 | "contents": "~a" 62 | }, 63 | { 64 | "tag": "VariablePattern", 65 | "contents": "~b" 66 | } 67 | ], 68 | [ 69 | { 70 | "tag": "WildcardPattern", 71 | "contents": [] 72 | }, 73 | { 74 | "tag": "WildcardPattern", 75 | "contents": [] 76 | } 77 | ] 78 | ], 79 | [ 80 | [ 81 | { 82 | "tag": "VariablePattern", 83 | "contents": "~a" 84 | }, 85 | { 86 | "tag": "VariablePattern", 87 | "contents": "~b" 88 | } 89 | ], 90 | [ 91 | { 92 | "tag": "WildcardPattern", 93 | "contents": [] 94 | }, 95 | { 96 | "tag": "WildcardPattern", 97 | "contents": [] 98 | } 99 | ] 100 | ], 101 | [ 102 | [ 103 | { 104 | "tag": "VariablePattern", 105 | "contents": "~a" 106 | }, 107 | { 108 | "tag": "VariablePattern", 109 | "contents": "~b" 110 | } 111 | ], 112 | [ 113 | { 114 | "tag": "WildcardPattern", 115 | "contents": [] 116 | }, 117 | { 118 | "tag": "WildcardPattern", 119 | "contents": [] 120 | } 121 | ] 122 | ], 123 | [ 124 | [ 125 | { 126 | "tag": "VariablePattern", 127 | "contents": "~a" 128 | }, 129 | { 130 | "tag": "VariablePattern", 131 | "contents": "~b" 132 | } 133 | ], 134 | [ 135 | { 136 | "tag": "WildcardPattern", 137 | "contents": [] 138 | }, 139 | { 140 | "tag": "WildcardPattern", 141 | "contents": [] 142 | } 143 | ] 144 | ], 145 | [ 146 | [ 147 | { 148 | "tag": "VariablePattern", 149 | "contents": "~a" 150 | }, 151 | { 152 | "tag": "VariablePattern", 153 | "contents": "~b" 154 | } 155 | ], 156 | [ 157 | { 158 | "tag": "WildcardPattern", 159 | "contents": [] 160 | }, 161 | { 162 | "tag": "WildcardPattern", 163 | "contents": [] 164 | } 165 | ] 166 | ], 167 | [ 168 | [ 169 | { 170 | "tag": "VariablePattern", 171 | "contents": "~a" 172 | }, 173 | { 174 | "tag": "VariablePattern", 175 | "contents": "~b" 176 | } 177 | ], 178 | [ 179 | { 180 | "tag": "WildcardPattern", 181 | "contents": [] 182 | }, 183 | { 184 | "tag": "WildcardPattern", 185 | "contents": [] 186 | } 187 | ] 188 | ] 189 | ] 190 | ] 191 | ] 192 | ] 193 | } 194 | -------------------------------------------------------------------------------- /data/exact/Tree.hs: -------------------------------------------------------------------------------- 1 | module Tree where 2 | 3 | data Tree a = Fork a (Tree a) (Tree a) | Nil 4 | 5 | func :: Tree a -> Int 6 | func Nil = 1 7 | func (Fork _ Nil Nil) = 2 8 | func (Fork _ Nil _) = 3 9 | func (Fork _ _ Nil) = 4 10 | -- Fork _ F F missing 11 | -------------------------------------------------------------------------------- /data/exact/TreeEval.hs: -------------------------------------------------------------------------------- 1 | module TreeEval where 2 | 3 | data Tree 4 | = Leaf 5 | | Node Tree Tree 6 | 7 | 8 | func' :: Tree -> Tree -> Int 9 | func' _ Leaf = 1 10 | func' (Node Leaf _) Leaf = 2 11 | func' _ _ = 3 12 | -------------------------------------------------------------------------------- /data/exact/TreeEval.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "func'", 7 | { 8 | "tag": "InaccessibleRhs", 9 | "contents": [ 10 | { 11 | "tag": "ConstructorPattern", 12 | "contents": [ 13 | "Node", 14 | [ 15 | { 16 | "tag": "ConstructorPattern", 17 | "contents": [ 18 | "Leaf", 19 | [] 20 | ] 21 | }, 22 | { 23 | "tag": "WildcardPattern", 24 | "contents": [] 25 | } 26 | ] 27 | ] 28 | }, 29 | { 30 | "tag": "ConstructorPattern", 31 | "contents": [ 32 | "Leaf", 33 | [] 34 | ] 35 | } 36 | ] 37 | } 38 | ] 39 | ], 40 | [ 41 | [ 42 | "func'", 43 | [ 44 | [ 45 | [ 46 | { 47 | "tag": "VariablePattern", 48 | "contents": "~a" 49 | }, 50 | { 51 | "tag": "VariablePattern", 52 | "contents": "~b" 53 | } 54 | ], 55 | [ 56 | { 57 | "tag": "WildcardPattern", 58 | "contents": [] 59 | }, 60 | { 61 | "tag": "VariablePattern", 62 | "contents": "~b" 63 | } 64 | ] 65 | ], 66 | [ 67 | [ 68 | { 69 | "tag": "VariablePattern", 70 | "contents": "~a" 71 | }, 72 | { 73 | "tag": "ConstructorPattern", 74 | "contents": [ 75 | "Node", 76 | [ 77 | { 78 | "tag": "VariablePattern", 79 | "contents": "~e" 80 | }, 81 | { 82 | "tag": "VariablePattern", 83 | "contents": "~f" 84 | } 85 | ] 86 | ] 87 | } 88 | ], 89 | [ 90 | { 91 | "tag": "VariablePattern", 92 | "contents": "~a" 93 | }, 94 | { 95 | "tag": "ConstructorPattern", 96 | "contents": [ 97 | "Node", 98 | [ 99 | { 100 | "tag": "WildcardPattern", 101 | "contents": [] 102 | }, 103 | { 104 | "tag": "WildcardPattern", 105 | "contents": [] 106 | } 107 | ] 108 | ] 109 | } 110 | ] 111 | ], 112 | [ 113 | [ 114 | { 115 | "tag": "ConstructorPattern", 116 | "contents": [ 117 | "Node", 118 | [ 119 | { 120 | "tag": "VariablePattern", 121 | "contents": "~q" 122 | }, 123 | { 124 | "tag": "VariablePattern", 125 | "contents": "~r" 126 | } 127 | ] 128 | ] 129 | }, 130 | { 131 | "tag": "ConstructorPattern", 132 | "contents": [ 133 | "Node", 134 | [ 135 | { 136 | "tag": "VariablePattern", 137 | "contents": "~e" 138 | }, 139 | { 140 | "tag": "VariablePattern", 141 | "contents": "~f" 142 | } 143 | ] 144 | ] 145 | } 146 | ], 147 | [ 148 | { 149 | "tag": "ConstructorPattern", 150 | "contents": [ 151 | "Node", 152 | [ 153 | { 154 | "tag": "VariablePattern", 155 | "contents": "~q" 156 | }, 157 | { 158 | "tag": "WildcardPattern", 159 | "contents": [] 160 | } 161 | ] 162 | ] 163 | }, 164 | { 165 | "tag": "ConstructorPattern", 166 | "contents": [ 167 | "Node", 168 | [ 169 | { 170 | "tag": "WildcardPattern", 171 | "contents": [] 172 | }, 173 | { 174 | "tag": "WildcardPattern", 175 | "contents": [] 176 | } 177 | ] 178 | ] 179 | } 180 | ] 181 | ] 182 | ] 183 | ] 184 | ] 185 | ] 186 | } 187 | -------------------------------------------------------------------------------- /data/exact/TreeTraversal.hs: -------------------------------------------------------------------------------- 1 | module TreeTraversal where 2 | 3 | data Tree a = Fork a (Tree a) (Tree a) | Nil 4 | 5 | func :: Tree a -> String 6 | func Nil = "Empty tree" 7 | func (Fork _ Nil Nil) = "Leaf" 8 | -- At this point, we need correct propagation of value abstraction to handle this precisely, i.e. 9 | -- deduce that that the last parameter can only be Fork 10 | func (Fork _ Nil _) = "Right subtree only" 11 | func (Fork _ _ Nil) = "Left subtree only" 12 | -- Fork _ F F missing 13 | -------------------------------------------------------------------------------- /data/exact/Trivial.hs: -------------------------------------------------------------------------------- 1 | module Trivial where 2 | 3 | -- Exhaustive 4 | i :: Int -> Int 5 | i _ | otherwise = 1 6 | -------------------------------------------------------------------------------- /data/exact/Trivial.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "i", 8 | [ 9 | [ 10 | [ 11 | { 12 | "tag": "VariablePattern", 13 | "contents": "~a" 14 | } 15 | ], 16 | [ 17 | { 18 | "tag": "WildcardPattern", 19 | "contents": [] 20 | } 21 | ] 22 | ] 23 | ] 24 | ] 25 | ] 26 | ] 27 | } 28 | -------------------------------------------------------------------------------- /data/exact/TrueGuard.hs: -------------------------------------------------------------------------------- 1 | module TrueGuard where 2 | 3 | orTrue :: Bool -> Bool 4 | orTrue _ | True = True -------------------------------------------------------------------------------- /data/exact/TrueGuard.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "orTrue", 8 | [ 9 | [ 10 | [ 11 | { 12 | "tag": "VariablePattern", 13 | "contents": "~a" 14 | } 15 | ], 16 | [ 17 | { 18 | "tag": "WildcardPattern", 19 | "contents": [] 20 | } 21 | ] 22 | ] 23 | ] 24 | ] 25 | ] 26 | ] 27 | } 28 | -------------------------------------------------------------------------------- /data/exact/Tuples.hs: -------------------------------------------------------------------------------- 1 | module Tuples where 2 | 3 | fst :: (a, b) -> a 4 | fst (x, _) = x 5 | 6 | snd :: (a, b) -> b 7 | snd (x, y) = y 8 | snd (x, y) = y 9 | -------------------------------------------------------------------------------- /data/exact/Tuples.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "snd", 7 | { 8 | "tag": "Redundant", 9 | "contents": [ 10 | { 11 | "tag": "TuplePattern", 12 | "contents": [ 13 | { 14 | "tag": "WildcardPattern", 15 | "contents": [] 16 | }, 17 | { 18 | "tag": "WildcardPattern", 19 | "contents": [] 20 | } 21 | ] 22 | } 23 | ] 24 | } 25 | ] 26 | ], 27 | [ 28 | [ 29 | "fst", 30 | [ 31 | [ 32 | [ 33 | { 34 | "tag": "VariablePattern", 35 | "contents": "~a" 36 | } 37 | ], 38 | [ 39 | { 40 | "tag": "VariablePattern", 41 | "contents": "~a" 42 | } 43 | ] 44 | ] 45 | ] 46 | ], 47 | [ 48 | "snd", 49 | [ 50 | [ 51 | [ 52 | { 53 | "tag": "VariablePattern", 54 | "contents": "~a" 55 | } 56 | ], 57 | [ 58 | { 59 | "tag": "VariablePattern", 60 | "contents": "~a" 61 | } 62 | ] 63 | ] 64 | ] 65 | ] 66 | ] 67 | ] 68 | } 69 | -------------------------------------------------------------------------------- /data/exact/TwoInts.hs: -------------------------------------------------------------------------------- 1 | f :: Int -> Int 2 | f 0 = 1 3 | f 1 = 2 4 | -------------------------------------------------------------------------------- /data/exact/TwoInts.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "f", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "VariablePattern", 14 | "contents": "~a" 15 | } 16 | ], 17 | "Constraints:\n ~k == False\n ~k == ~a == 1\n ~e == False\n ~e == ~a == 0\n\nSatisfiable. Model:\n ~k = False :: Bool\n ~a = 2 :: Integer\n ~e = False :: Bool\n" 18 | ] 19 | ] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | "f", 26 | [ 27 | [ 28 | [ 29 | { 30 | "tag": "VariablePattern", 31 | "contents": "~a" 32 | } 33 | ], 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ], 41 | [ 42 | [ 43 | { 44 | "tag": "VariablePattern", 45 | "contents": "~a" 46 | } 47 | ], 48 | [ 49 | { 50 | "tag": "WildcardPattern", 51 | "contents": [] 52 | } 53 | ] 54 | ] 55 | ] 56 | ] 57 | ] 58 | ] 59 | } 60 | -------------------------------------------------------------------------------- /data/exact/TypeClass.hs: -------------------------------------------------------------------------------- 1 | module TypeClass where 2 | 3 | unsound :: Num a => a -> Int 4 | unsound x 5 | | x <= 0 = 1 6 | | x >= 1 = 2 7 | -- Exhaustive for integrals, but not for double, for example. 8 | -- Our solver says nothing while this should probably get some warning that it's not exhaustive. 9 | -------------------------------------------------------------------------------- /data/exact/TypeClass.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "unsound", 8 | [ 9 | [ 10 | [ 11 | { 12 | "tag": "VariablePattern", 13 | "contents": "~a" 14 | } 15 | ], 16 | [ 17 | { 18 | "tag": "WildcardPattern", 19 | "contents": [] 20 | } 21 | ] 22 | ], 23 | [ 24 | [ 25 | { 26 | "tag": "VariablePattern", 27 | "contents": "~a" 28 | } 29 | ], 30 | [ 31 | { 32 | "tag": "WildcardPattern", 33 | "contents": [] 34 | } 35 | ] 36 | ] 37 | ] 38 | ] 39 | ] 40 | ] 41 | } 42 | -------------------------------------------------------------------------------- /data/exact/TypeVariable.hs: -------------------------------------------------------------------------------- 1 | module TypeVariable where 2 | 3 | data MyTrinary = A | B | C 4 | data Container a = ContainerC a | Nope 5 | 6 | unpack :: Container a -> a 7 | unpack (ContainerC x) = x 8 | unpack (ContainerC x) = x 9 | 10 | -------------------------------------------------------------------------------- /data/exact/TypeVariable.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "unpack", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "Nope", 16 | [] 17 | ] 18 | } 19 | ], 20 | "" 21 | ] 22 | ] 23 | } 24 | ], 25 | [ 26 | "unpack", 27 | { 28 | "tag": "Redundant", 29 | "contents": [ 30 | { 31 | "tag": "ConstructorPattern", 32 | "contents": [ 33 | "ContainerC", 34 | [ 35 | { 36 | "tag": "WildcardPattern", 37 | "contents": [] 38 | } 39 | ] 40 | ] 41 | } 42 | ] 43 | } 44 | ] 45 | ], 46 | [ 47 | [ 48 | "unpack", 49 | [ 50 | [ 51 | [ 52 | { 53 | "tag": "VariablePattern", 54 | "contents": "~a" 55 | } 56 | ], 57 | [ 58 | { 59 | "tag": "VariablePattern", 60 | "contents": "~a" 61 | } 62 | ] 63 | ] 64 | ] 65 | ] 66 | ] 67 | ] 68 | } 69 | -------------------------------------------------------------------------------- /data/exact/Variables.hs: -------------------------------------------------------------------------------- 1 | module Variables where 2 | 3 | f :: Bool -> Bool -> Integer 4 | f True y = 1 5 | f x y = 2 6 | 7 | incompleteF :: Bool -> Bool -> Integer 8 | incompleteF True y = 1 9 | incompleteF x False = 2 10 | 11 | data MyTrinary = A | B | C 12 | 13 | extract :: Maybe MyTrinary -> Bool -> MyTrinary 14 | extract (Just x) False = x 15 | extract (Just C) True = C 16 | 17 | -------------------------------------------------------------------------------- /data/exact/Variables.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [ 5 | [ 6 | "incompleteF", 7 | { 8 | "tag": "NonExhaustive", 9 | "contents": [ 10 | [ 11 | [ 12 | { 13 | "tag": "ConstructorPattern", 14 | "contents": [ 15 | "False", 16 | [] 17 | ] 18 | }, 19 | { 20 | "tag": "ConstructorPattern", 21 | "contents": [ 22 | "True", 23 | [] 24 | ] 25 | } 26 | ], 27 | "" 28 | ] 29 | ] 30 | } 31 | ], 32 | [ 33 | "extract", 34 | { 35 | "tag": "NonExhaustive", 36 | "contents": [ 37 | [ 38 | [ 39 | { 40 | "tag": "ConstructorPattern", 41 | "contents": [ 42 | "Nothing", 43 | [] 44 | ] 45 | }, 46 | { 47 | "tag": "WildcardPattern", 48 | "contents": [] 49 | } 50 | ], 51 | "" 52 | ], 53 | [ 54 | [ 55 | { 56 | "tag": "ConstructorPattern", 57 | "contents": [ 58 | "Just", 59 | [ 60 | { 61 | "tag": "ConstructorPattern", 62 | "contents": [ 63 | "A", 64 | [] 65 | ] 66 | } 67 | ] 68 | ] 69 | }, 70 | { 71 | "tag": "ConstructorPattern", 72 | "contents": [ 73 | "True", 74 | [] 75 | ] 76 | } 77 | ], 78 | "" 79 | ], 80 | [ 81 | [ 82 | { 83 | "tag": "ConstructorPattern", 84 | "contents": [ 85 | "Just", 86 | [ 87 | { 88 | "tag": "ConstructorPattern", 89 | "contents": [ 90 | "B", 91 | [] 92 | ] 93 | } 94 | ] 95 | ] 96 | }, 97 | { 98 | "tag": "ConstructorPattern", 99 | "contents": [ 100 | "True", 101 | [] 102 | ] 103 | } 104 | ], 105 | "" 106 | ] 107 | ] 108 | } 109 | ] 110 | ], 111 | [ 112 | [ 113 | "f", 114 | [ 115 | [ 116 | [ 117 | { 118 | "tag": "VariablePattern", 119 | "contents": "~a" 120 | }, 121 | { 122 | "tag": "VariablePattern", 123 | "contents": "~b" 124 | } 125 | ], 126 | [ 127 | { 128 | "tag": "VariablePattern", 129 | "contents": "~a" 130 | }, 131 | { 132 | "tag": "WildcardPattern", 133 | "contents": [] 134 | } 135 | ] 136 | ] 137 | ] 138 | ], 139 | [ 140 | "incompleteF", 141 | [ 142 | [ 143 | [ 144 | { 145 | "tag": "VariablePattern", 146 | "contents": "~a" 147 | }, 148 | { 149 | "tag": "VariablePattern", 150 | "contents": "~b" 151 | } 152 | ], 153 | [ 154 | { 155 | "tag": "VariablePattern", 156 | "contents": "~a" 157 | }, 158 | { 159 | "tag": "WildcardPattern", 160 | "contents": [] 161 | } 162 | ] 163 | ], 164 | [ 165 | [ 166 | { 167 | "tag": "ConstructorPattern", 168 | "contents": [ 169 | "False", 170 | [] 171 | ] 172 | }, 173 | { 174 | "tag": "VariablePattern", 175 | "contents": "~b" 176 | } 177 | ], 178 | [ 179 | { 180 | "tag": "ConstructorPattern", 181 | "contents": [ 182 | "False", 183 | [] 184 | ] 185 | }, 186 | { 187 | "tag": "VariablePattern", 188 | "contents": "~b" 189 | } 190 | ] 191 | ] 192 | ] 193 | ], 194 | [ 195 | "extract", 196 | [ 197 | [ 198 | [ 199 | { 200 | "tag": "VariablePattern", 201 | "contents": "~a" 202 | }, 203 | { 204 | "tag": "VariablePattern", 205 | "contents": "~b" 206 | } 207 | ], 208 | [ 209 | { 210 | "tag": "VariablePattern", 211 | "contents": "~a" 212 | }, 213 | { 214 | "tag": "WildcardPattern", 215 | "contents": [] 216 | } 217 | ] 218 | ], 219 | [ 220 | [ 221 | { 222 | "tag": "ConstructorPattern", 223 | "contents": [ 224 | "Just", 225 | [ 226 | { 227 | "tag": "VariablePattern", 228 | "contents": "~f" 229 | } 230 | ] 231 | ] 232 | }, 233 | { 234 | "tag": "VariablePattern", 235 | "contents": "~b" 236 | } 237 | ], 238 | [ 239 | { 240 | "tag": "ConstructorPattern", 241 | "contents": [ 242 | "Just", 243 | [ 244 | { 245 | "tag": "WildcardPattern", 246 | "contents": [] 247 | } 248 | ] 249 | ] 250 | }, 251 | { 252 | "tag": "VariablePattern", 253 | "contents": "~b" 254 | } 255 | ] 256 | ], 257 | [ 258 | [ 259 | { 260 | "tag": "ConstructorPattern", 261 | "contents": [ 262 | "Just", 263 | [ 264 | { 265 | "tag": "VariablePattern", 266 | "contents": "~e" 267 | } 268 | ] 269 | ] 270 | }, 271 | { 272 | "tag": "ConstructorPattern", 273 | "contents": [ 274 | "True", 275 | [] 276 | ] 277 | } 278 | ], 279 | [ 280 | { 281 | "tag": "ConstructorPattern", 282 | "contents": [ 283 | "Just", 284 | [ 285 | { 286 | "tag": "VariablePattern", 287 | "contents": "~e" 288 | } 289 | ] 290 | ] 291 | }, 292 | { 293 | "tag": "ConstructorPattern", 294 | "contents": [ 295 | "True", 296 | [] 297 | ] 298 | } 299 | ] 300 | ] 301 | ] 302 | ] 303 | ] 304 | ] 305 | } 306 | -------------------------------------------------------------------------------- /data/exact/Wildcard.hs: -------------------------------------------------------------------------------- 1 | module Wildcard where 2 | 3 | data MyTrinary = A | B | C 4 | 5 | data MyMaybe = Sum MyTrinary | Nope 6 | 7 | extract :: MyMaybe -> MyMaybe-> MyTrinary 8 | extract (Sum A) _ = A 9 | extract (Sum B) _ = B 10 | extract _ (Sum B) = B 11 | extract _ (Sum C) = B 12 | {- 13 | Uncovered: 14 | Sum C, Sum A 15 | Sum C, Nope 16 | Nope, Sum A 17 | Nope, Nope 18 | -} 19 | -------------------------------------------------------------------------------- /data/exact/Word8.hs: -------------------------------------------------------------------------------- 1 | -- Exhaustive, but our solver won't figure that out. 2 | f :: Word8 -> Int 3 | f x | x >= 0 && x < 256 = 1 4 | 5 | -------------------------------------------------------------------------------- /data/exact/Word8.hs.expected: -------------------------------------------------------------------------------- 1 | { 2 | "tag": "AnalysisSuccess", 3 | "contents": [ 4 | [], 5 | [ 6 | [ 7 | "f", 8 | [ 9 | [ 10 | [ 11 | { 12 | "tag": "VariablePattern", 13 | "contents": "~a" 14 | } 15 | ], 16 | [ 17 | { 18 | "tag": "WildcardPattern", 19 | "contents": [] 20 | } 21 | ] 22 | ] 23 | ] 24 | ] 25 | ] 26 | ] 27 | } 28 | -------------------------------------------------------------------------------- /data/shouldNotParse/duplicateSignature.hs: -------------------------------------------------------------------------------- 1 | fun :: Int 2 | fun :: Int 3 | fun = 5 4 | -------------------------------------------------------------------------------- /data/shouldNotParse/infixdataconstructor.hs: -------------------------------------------------------------------------------- 1 | data MyList a 2 | = Nil 3 | | a :-: MyList a 4 | -------------------------------------------------------------------------------- /data/shouldNotParse/missingImplementation.hs: -------------------------------------------------------------------------------- 1 | fun :: Int 2 | -------------------------------------------------------------------------------- /data/shouldNotParse/recordDataConstructor.hs: -------------------------------------------------------------------------------- 1 | data Record = Record 2 | { fieldOne :: String 3 | , fieldTwo :: Bool 4 | } 5 | -------------------------------------------------------------------------------- /hooks.sus: -------------------------------------------------------------------------------- 1 | card hooks { 2 | into .git/hooks 3 | outof scripts 4 | pre_commit_test.sh -> pre-commit 5 | pre_push_test.sh -> pre-push 6 | } 7 | -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | build: FORCE 2 | stack build 3 | 4 | install: FORCE 5 | stack install 6 | 7 | pedantic: FORCE 8 | stack clean 9 | stack build \ 10 | --fast \ 11 | --jobs=8 \ 12 | --ghc-options="\ 13 | -fforce-recomp \ 14 | -O0 \ 15 | -Wall \ 16 | -Werror \ 17 | -fwarn-unused-imports \ 18 | -fwarn-incomplete-patterns \ 19 | -fwarn-unused-do-bind \ 20 | -fno-warn-type-defaults \ 21 | -fno-warn-name-shadowing \ 22 | -fno-warn-overlapping-patterns \ 23 | -fno-warn-orphans" 24 | 25 | test: FORCE 26 | stack test 27 | 28 | love: 29 | @echo "not war" 30 | 31 | FORCE: 32 | 33 | 34 | -------------------------------------------------------------------------------- /patterns.cabal: -------------------------------------------------------------------------------- 1 | name: patterns 2 | version: 0.1.0.0 3 | synopsis: Pattern matching program analysis 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/patterns#readme 6 | license: OtherLicense 7 | license-file: CRAPL-LICENSE.txt 8 | author: Pavel Kalvoda and Tom Sydney Kerckhove 9 | maintainer: syd.kerckhove@gmail.com 10 | copyright: 2016 Pavel Kalvoda and Tom Sydney Kerckhove 11 | category: System 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults 19 | exposed-modules: Lib 20 | , Util 21 | , ClauseProcessing 22 | , DataDefs 23 | , OptParse 24 | , OptParse.Types 25 | , Types 26 | , Gatherer 27 | , TH 28 | , Oracle 29 | , Oracle.SBVQueries 30 | , Evaluatedness 31 | build-depends: base >= 4.9 && < 5 32 | , containers >= 0.5 && < 0.6 33 | , haskell-src-exts >= 1.17 && < 1.18 34 | , aeson-pretty >= 0.7 && < 0.8 35 | , aeson >= 0.11 && < 0.12 36 | , bytestring >= 0.10 && < 0.11 37 | , sbv >= 5.12 && < 5.13 38 | , optparse-applicative >= 0.12 && < 0.13 39 | , mtl >= 2.2 && < 2.3 40 | , transformers >= 0.5 && < 0.6 41 | , template-haskell >= 2.11 && < 2.12 42 | , pretty-show >= 1.6 && < 1.7 43 | default-language: Haskell2010 44 | 45 | executable patterns 46 | hs-source-dirs: app 47 | main-is: Main.hs 48 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults 49 | build-depends: base 50 | , patterns 51 | default-language: Haskell2010 52 | 53 | test-suite patterns-test 54 | type: exitcode-stdio-1.0 55 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-type-defaults 56 | hs-source-dirs: test 57 | main-is: MainTest.hs 58 | other-modules: LibSpec 59 | GathererSpec 60 | ClauseProcessingSpec 61 | OracleSpec 62 | Oracle.SBVQueriesSpec 63 | Oracle.TestUtils 64 | TestUtils 65 | build-depends: base 66 | , patterns 67 | , hspec >= 2.2 && < 2.3 68 | , hspec-core >= 2.2 && < 2.3 69 | , HUnit >= 1.3 && < 1.4 70 | , QuickCheck >= 2.8 && < 2.9 71 | , sbv >= 5.12 && < 5.13 72 | , containers >= 0.5 && < 0.6 73 | , directory >= 1.2.5 && < 1.3 74 | , filepath >= 1.4 && < 1.5 75 | , haskell-src-exts >= 1.17 && < 1.18 76 | , aeson-pretty >= 0.7 && < 0.8 77 | , mtl >= 2.2 && < 2.3 78 | , aeson >= 0.11 && < 0.12 79 | , bytestring >= 0.10 && < 0.11 80 | 81 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 82 | default-language: Haskell2010 83 | 84 | source-repository head 85 | type: git 86 | location: https://github.com/githubuser/patterns 87 | -------------------------------------------------------------------------------- /src/Evaluatedness.hs: -------------------------------------------------------------------------------- 1 | module Evaluatedness where 2 | 3 | import DataDefs 4 | import Types 5 | 6 | for :: [a] -> (a -> b) -> [b] 7 | for = flip map 8 | 9 | produceEvaluatednesses :: FunctionTarget -> FunctionResult -> Evaluatedness 10 | produceEvaluatednesses (FunctionTarget (Function name _ _)) (FunctionResult et) 11 | = Evaluatedness name 12 | $ concat 13 | $ for et $ \cc -> 14 | for (capD cc) $ \CVAV {valueAbstraction = va, delta = d} -> 15 | -- trace (unlines $ map (\(v, vt) -> v ++ " :: " ++ pretty vt) $ Map.toList g) $ 16 | ( va 17 | , for va $ evalness $ bottomAssertedVariables d 18 | ) 19 | 20 | evalness :: [Name] -> Pattern -> Pattern 21 | evalness ns = go 22 | where 23 | go :: Pattern -> Pattern 24 | go (VariablePattern n) 25 | | n `elem` ns = VariablePattern n -- TODO replace this with all the constructors. 26 | | otherwise = WildcardPattern -- If there is no 'IsBottom' constraint for this var, it won't be evaluated here. 27 | go p@(LiteralPattern _ _) = p 28 | go (ConstructorPattern n ps) = ConstructorPattern n $ map go ps 29 | go (TuplePattern ps) = TuplePattern $ map go ps 30 | go EmptyListPattern = EmptyListPattern 31 | go (InfixConstructorPattern p1 n p2) = InfixConstructorPattern (go p1) n (go p2) 32 | go WildcardPattern = WildcardPattern 33 | go IntVariablePattern = IntVariablePattern 34 | go (GuardPattern p n) = GuardPattern (go p) n 35 | 36 | bottomAssertedVariables :: ConstraintSet -> [Name] 37 | bottomAssertedVariables = concatMap go . termConstraints 38 | where 39 | go (IsBottom n) = [n] 40 | go _ = [] 41 | 42 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib where 2 | 3 | 4 | import ClauseProcessing 5 | import Control.Monad (forM, forM_, replicateM) 6 | import Control.Monad.Except (runExceptT) 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Reader (ReaderT (..), runReader) 9 | import Control.Monad.State (evalStateT) 10 | import Data.Aeson.Encode.Pretty (encodePretty) 11 | import qualified Data.ByteString.Lazy.Char8 as LB8 12 | import Data.Either (lefts, rights) 13 | import qualified Data.Map as Map 14 | import Data.Maybe (mapMaybe) 15 | import Data.SBV 16 | import DataDefs 17 | import Evaluatedness 18 | import Gatherer 19 | import Language.Haskell.Exts (fromParseResult, parseFile) 20 | import OptParse 21 | import OptParse.Types 22 | import Oracle 23 | import Oracle.SBVQueries 24 | import Types 25 | import Util 26 | 27 | 28 | patterns :: IO () 29 | patterns = do 30 | -- svbTest 31 | sets <- getSettings 32 | -- print sets 33 | case setsCommand sets of 34 | Analyze file -> do 35 | res <- flip runReaderT sets $ processTarget file 36 | prettyOutput res 37 | AnalyzeEvaluatedness file -> do 38 | res <- flip runReaderT sets $ processTarget file 39 | prettyOutputEvaluatedness res 40 | DumpResults file -> do 41 | res <- flip runReaderT sets $ processTarget file 42 | LB8.putStrLn $ encodePretty res 43 | 44 | type Configured = ReaderT Settings IO 45 | 46 | processTarget :: FilePath -> Configured AnalysisResult 47 | processTarget inputFile = do 48 | ast <- liftIO $ fromParseResult <$> parseFile inputFile 49 | -- print ast 50 | let ass = AnalysisAssigment inputFile ast 51 | processAssignment ass 52 | 53 | processAssignment :: AnalysisAssigment -> Configured AnalysisResult 54 | processAssignment (AnalysisAssigment _ ast) 55 | = case (,) <$> getFunctions ast <*> getTypeUniverse ast of 56 | Left err -> return $ AnalysisError [GatherError err] 57 | Right (fs, ptcm) -> do 58 | let targets = map FunctionTarget fs 59 | initState = AnalyzerState 0 60 | -- LB.putStr $ encodePretty targets 61 | ress <- forM targets $ \target -> do 62 | debug "Analysing target:" 63 | debugShow target 64 | case flip runReader ptcm 65 | $ flip evalStateT initState 66 | $ runExceptT 67 | $ analyzeFunction target 68 | of 69 | Left err -> do 70 | debug "Something went wrong while analyzing this target:" 71 | debugShow err 72 | return $ Left err 73 | Right res -> do 74 | debug "Trace gathered during analysis:" 75 | debugShow res 76 | -- Solve the constraints 77 | sres <- liftIO $ runOracle res 78 | debug "Result oracle consultation:" 79 | debugShow sres 80 | return $ Right 81 | ( produceRecommendations target sres 82 | , produceEvaluatednesses target res 83 | ) 84 | case lefts ress of 85 | [] -> do 86 | let rss = concatMap fst $ rights ress 87 | evs = map snd $ rights ress 88 | return $ AnalysisSuccess rss evs 89 | rs -> return $ AnalysisError $ map ProcessError rs 90 | 91 | produceRecommendations :: FunctionTarget -> SolvedFunctionResult -> [Recommendation] 92 | produceRecommendations (FunctionTarget (Function name _ clss)) (SolvedFunctionResult tr) 93 | = map (Recommendation name) 94 | $ findNonExhaustives tr 95 | ++ findRedundants tr 96 | ++ findInaccessibleRhss tr 97 | where 98 | findNonExhaustives :: SolvedExecutionTrace -> [RecommendationReason] 99 | findNonExhaustives [] = [] 100 | findNonExhaustives tr 101 | = case scapU $ last tr of 102 | [] -> [] 103 | cvavs -> [NonExhaustive $ map formatResult cvavs] 104 | 105 | where 106 | formatResult (SolvedValueAbstractionVector vec Nothing) = (makePrettyClause [] (Clause vec), "") 107 | formatResult (SolvedValueAbstractionVector vec (Just (bes, m))) 108 | = if null $ varsInVAV vec 109 | then (makePrettyClause [] $ Clause vec, "") 110 | else (makePrettyClause vars $ Clause vec, str) 111 | where 112 | varsInVAV :: ValueAbstractionVector -> [Name] 113 | varsInVAV = concatMap varsInPattern 114 | where 115 | varsInPattern :: Pattern -> [Name] 116 | varsInPattern (VariablePattern n) = [n] 117 | varsInPattern (LiteralPattern _ _) = [] 118 | varsInPattern (ConstructorPattern _ ps) = concatMap varsInPattern ps 119 | varsInPattern (TuplePattern ps) = concatMap varsInPattern ps 120 | varsInPattern EmptyListPattern = [] 121 | varsInPattern (InfixConstructorPattern p1 _ p2) = concatMap varsInPattern [p1, p2] 122 | varsInPattern WildcardPattern = [] 123 | varsInPattern IntVariablePattern = [] 124 | varsInPattern (GuardPattern p _) = varsInPattern p 125 | vars = concatMap varsInBE bes 126 | str = unlines ["Constraints:\n" ++ unlines (map ((" " ++) . pretty) bes), show $ SatResult $ Satisfiable z3 m] 127 | 128 | findRedundants :: SolvedExecutionTrace -> [RecommendationReason] 129 | findRedundants tr = mapMaybe checkRedundant $ zip tr clss 130 | where 131 | checkRedundant :: (SolvedClauseCoverage, Clause) -> Maybe RecommendationReason 132 | checkRedundant (cc, c) 133 | | null (scapC cc) && null (scapD cc) = Just $ Redundant $ makePrettyClause [] c 134 | | otherwise = Nothing 135 | 136 | findInaccessibleRhss :: SolvedExecutionTrace -> [RecommendationReason] 137 | findInaccessibleRhss tr = mapMaybe checkInaccessibleRhs $ zip tr clss 138 | where 139 | checkInaccessibleRhs :: (SolvedClauseCoverage, Clause) -> Maybe RecommendationReason 140 | checkInaccessibleRhs (cc, c) 141 | | null (scapC cc) && (not . null) (scapD cc) = Just $ InaccessibleRhs $ makePrettyClause [] c 142 | | otherwise = Nothing 143 | 144 | makePrettyClause :: [Name] -> Clause -> Clause 145 | makePrettyClause ns (Clause ps) = Clause $ map (makeVarsWildcards ns) ps 146 | 147 | makeVarsWildcards :: [Name] -> Pattern -> Pattern 148 | makeVarsWildcards ns (VariablePattern n) = if n `elem` ns then VariablePattern n else WildcardPattern 149 | makeVarsWildcards _ l@(LiteralPattern _ _) = l 150 | makeVarsWildcards ns (ConstructorPattern n ps) = ConstructorPattern n $ map (makeVarsWildcards ns) ps 151 | makeVarsWildcards ns (TuplePattern ps) = TuplePattern $ map (makeVarsWildcards ns) ps 152 | makeVarsWildcards _ EmptyListPattern = EmptyListPattern 153 | makeVarsWildcards _ WildcardPattern = WildcardPattern 154 | makeVarsWildcards ns (GuardPattern p e) = GuardPattern (makeVarsWildcards ns p) e 155 | makeVarsWildcards ns (InfixConstructorPattern p1 name p2) = InfixConstructorPattern (makeVarsWildcards ns p1) name (makeVarsWildcards ns p2) 156 | makeVarsWildcards _ IntVariablePattern = IntVariablePattern 157 | 158 | 159 | prettyOutput :: AnalysisResult -> IO () 160 | prettyOutput (AnalysisError err) = print err 161 | prettyOutput (AnalysisSuccess recs _) = forM_ recs $ \(Recommendation n r) -> do 162 | putStrLn $ "In function " ++ n ++ ":" 163 | case r of 164 | Redundant c -> do 165 | putStrLn "The following clause is redundant:" 166 | printClause n c 167 | InaccessibleRhs c -> do 168 | putStrLn "The following clause has an inaccesible right hand side:" 169 | printClause n c 170 | NonExhaustive cs -> do 171 | putStrLn "The patterns may not be exhaustive, the following clauses are missing:" 172 | forM_ cs $ \(c, s) -> do 173 | printClause n c 174 | putStr s 175 | putStrLn "" 176 | where 177 | printClause :: Name -> Clause -> IO () 178 | printClause n c = do 179 | putStr n 180 | putStr " " 181 | prettyPrint c 182 | 183 | prettyOutputEvaluatedness :: AnalysisResult -> IO () 184 | prettyOutputEvaluatedness (AnalysisError err) = print err 185 | prettyOutputEvaluatedness (AnalysisSuccess _ evs) = forM_ evs $ \(Evaluatedness name es) -> do 186 | putStrLn $ "Evaluatedness of function \"" ++ name ++ "\"" 187 | putStrLn "" 188 | forM_ es $ \(inp, oup) -> do 189 | putStr $ name ++ " " 190 | prettyPrint inp 191 | putStrLn "" 192 | let ll = (+2) $ maximum $ map (length . pretty) inp 193 | forM_ (zip inp oup) $ \(ip, p) -> do 194 | putStr $ pad ' ' ll $ pretty ip ++ ": " 195 | putStrLn $ pretty p 196 | putStrLn "" 197 | putStrLn "" 198 | putStrLn "" 199 | 200 | pad :: Char -> Int -> String -> String 201 | pad c i s 202 | | length s < i = s ++ replicate (i - length s) c 203 | | otherwise = s 204 | 205 | gammaVAV :: Binding -> ConditionedValueAbstractionVector 206 | gammaVAV gamma 207 | = CVAV 208 | { valueAbstraction = [] 209 | , delta = ConstraintSet 210 | { termConstraints = [] 211 | , typeConstraints = [] 212 | } 213 | , gamma = gamma 214 | } 215 | 216 | 217 | patAppend :: Pattern -> ConditionedValueAbstractionVector -> ConditionedValueAbstractionVector 218 | patAppend p cvav = CVAV (p:valueAbstraction cvav) (gamma cvav) (delta cvav) 219 | 220 | 221 | addIntegerBound :: Pattern -> Name -> Binding -> ConditionedValueAbstractionVector -> Integer -> Analyzer ConditionedValueAbstractionVector 222 | addIntegerBound vp name gamma subVAV bound = do 223 | falseVar <- freshVar 224 | let gamma' = Map.insert (varName falseVar) (TypeConstructor "Bool") gamma 225 | let boundsContraint 226 | = VarEqualsBool 227 | (varName falseVar) 228 | (BoolOp 229 | BoolAnd 230 | (IntBoolOp IntGE (IntVar name) (IntLit 0)) 231 | (IntBoolOp IntLT (IntVar name) (IntLit bound))) 232 | let d = delta subVAV 233 | let d' = addConstraint boundsContraint d 234 | let d'' = addConstraint (VarEqualsCons (varName falseVar) "True" []) d' 235 | return $ CVAV (vp:valueAbstraction subVAV) gamma' d'' 236 | 237 | extractTypingConstraints :: Binding -> ValueAbstractionVector -> Analyzer ConditionedValueAbstractionVector 238 | extractTypingConstraints gamma [] 239 | = return $ gammaVAV gamma 240 | 241 | extractTypingConstraints gamma (vp@(VariablePattern name):vs) = do 242 | subVAV <- extractTypingConstraints gamma vs 243 | case Map.lookup name gamma of 244 | Just (TypeConstructor "Word8") -> addIntegerBound vp name gamma subVAV (2 ^ 8 ) 245 | Just (TypeConstructor "Word16") -> addIntegerBound vp name gamma subVAV (2 ^ 16) 246 | Just (TypeConstructor "Word32") -> addIntegerBound vp name gamma subVAV (2 ^ 32) 247 | Just (TypeConstructor "Word64") -> addIntegerBound vp name gamma subVAV (2 ^ 64) 248 | _ -> return $ patAppend vp subVAV 249 | extractTypingConstraints gamma (v:vs) = do 250 | subVAV <- extractTypingConstraints gamma vs 251 | return $ patAppend v subVAV 252 | 253 | -- | Constructs ConditionedValueAbstractionSet without any conditions on each abstraction, apart from 254 | -- | those imposed by gamma 255 | withNoConstraints :: ValueAbstractionSet -> Binding -> Analyzer ConditionedValueAbstractionSet 256 | withNoConstraints vas gamma 257 | = mapM (extractTypingConstraints gamma) vas 258 | 259 | 260 | analyzeFunction :: FunctionTarget -> Analyzer FunctionResult 261 | analyzeFunction (FunctionTarget fun) = do 262 | freshVars <- {- trace (Pr.ppShow fun) $ -} replicateM (arity (head clauses)) freshVar 263 | let Right gamma = initialGamma fun freshVars 264 | initialAbstraction <- withNoConstraints [freshVars] gamma 265 | executionTrace <- {- trace (Pr.ppShow desugaredPatterns) $ -} iteratedVecProc desugaredPatterns initialAbstraction 266 | return $ FunctionResult executionTrace 267 | where 268 | Function _ _ clauses = fun 269 | Right patterns = getPatternVectors fun 270 | desugaredPatterns = map desugarPatternVector patterns 271 | 272 | -------------------------------------------------------------------------------- /src/OptParse.hs: -------------------------------------------------------------------------------- 1 | module OptParse where 2 | 3 | import Options.Applicative 4 | import System.Environment (getArgs) 5 | 6 | import OptParse.Types 7 | 8 | getSettings :: IO Settings 9 | getSettings = do 10 | argv <- getArgs 11 | (command, args) <- parseArgs argv 12 | conf <- getConfig args 13 | case buildSettings command args conf of 14 | Left probl -> error $ "Could not build settings from arguments and config: " ++ probl 15 | Right sets -> return sets 16 | 17 | buildSettings :: Command -> Arguments -> Configuration -> Either String Settings 18 | buildSettings command args _ = Right Settings 19 | { setsCommand = command 20 | , setsDebug = argsDebug args 21 | } 22 | 23 | defaultSettings :: Settings 24 | defaultSettings = Settings { setsCommand = Analyze undefined, setsDebug = False } 25 | 26 | getConfig :: Arguments -> IO Configuration 27 | getConfig _ = return Configuration 28 | 29 | parseArgs :: [String] -> IO (Command, Arguments) 30 | parseArgs args = handleParseResult $ execParserPure prefs myParser args 31 | where 32 | prefs = defaultPrefs 33 | { prefMultiSuffix = "PATTERNS" 34 | , prefDisambiguate = True 35 | , prefShowHelpOnError = True 36 | , prefBacktrack = True 37 | , prefColumns = 80 38 | } 39 | 40 | 41 | myParser :: ParserInfo (Command, Arguments) 42 | myParser = info (helper <*> parser) help 43 | where 44 | parser = (,) <$> commandP <*> argumentsP 45 | help = fullDesc <> progDesc descr 46 | descr = unlines 47 | [ "Analyse pattern matching" 48 | , "by Pavel Kalvoda and Tom Sydney Kerckhove" 49 | ] 50 | 51 | commandP :: Parser Command 52 | commandP = hsubparser $ mconcat 53 | [ command "analyze" parseAnalyze 54 | , command "evaluatedness" parseEvaluatedness 55 | , command "dump-results" parseDumpResults 56 | ] 57 | 58 | parseAnalyze :: ParserInfo Command 59 | parseAnalyze = info parser modifier 60 | where 61 | parser = Analyze <$> strArgument (metavar "FILE" <> help "the file to analyze") 62 | modifier = fullDesc <> progDesc "Analyze and present recommendations" 63 | 64 | parseEvaluatedness :: ParserInfo Command 65 | parseEvaluatedness = info parser modifier 66 | where 67 | parser = AnalyzeEvaluatedness <$> strArgument (metavar "FILE" <> help "the file for which to generate evaluatedness") 68 | modifier = fullDesc <> progDesc "Present evaluatedness" 69 | 70 | parseDumpResults :: ParserInfo Command 71 | parseDumpResults = info parser modifier 72 | where 73 | parser = DumpResults <$> strArgument (metavar "FILE" <> help "the file for which to generate test results") 74 | modifier = fullDesc <> progDesc "Dump analysis results for testing" 75 | 76 | argumentsP :: Parser Arguments 77 | argumentsP 78 | = Arguments 79 | <$> switch 80 | ( short 'd' 81 | <> long "debug" 82 | <> help "turn on debug information") 83 | -------------------------------------------------------------------------------- /src/OptParse/Types.hs: -------------------------------------------------------------------------------- 1 | module OptParse.Types where 2 | 3 | 4 | -- | Kept throughout the program 5 | data Settings = Settings 6 | { setsCommand :: Command 7 | , setsDebug :: Bool 8 | } deriving (Show, Eq) 9 | 10 | -- | Command-line arguments 11 | data Arguments = Arguments 12 | { argsDebug :: Bool 13 | } deriving (Show, Eq) 14 | 15 | -- | Configuration, from config file 16 | data Configuration = Configuration 17 | deriving (Show, Eq) 18 | 19 | 20 | data Command 21 | = Analyze FilePath 22 | | AnalyzeEvaluatedness FilePath 23 | | DumpResults FilePath 24 | deriving (Show, Eq) 25 | -------------------------------------------------------------------------------- /src/Oracle.hs: -------------------------------------------------------------------------------- 1 | module Oracle where 2 | 3 | import Data.List (find) 4 | import Data.Maybe (catMaybes) 5 | import Data.SBV 6 | import DataDefs 7 | import Oracle.SBVQueries 8 | import Types 9 | 10 | data Oracle 11 | = Oracle 12 | { queryOracle :: ConditionedValueAbstractionVector -> IO OracleResult } 13 | 14 | 15 | -- Just IO? 16 | runOracle :: FunctionResult -> IO SolvedFunctionResult 17 | runOracle (FunctionResult tr) = SolvedFunctionResult <$> mapM runCoverageOracle tr 18 | 19 | runCoverageOracle :: ClauseCoverage -> IO SolvedClauseCoverage 20 | runCoverageOracle cc 21 | = SolvedClauseCoverage 22 | <$> runCoverageSetOracle (capC cc) 23 | <*> runCoverageSetOracle (capU cc) 24 | <*> runCoverageSetOracle (capD cc) 25 | 26 | runCoverageSetOracle :: ConditionedValueAbstractionSet -> IO SolvedValueAbstractionSet 27 | runCoverageSetOracle cvas = catMaybes <$> mapM runSingleVectorOracle cvas 28 | 29 | runSingleVectorOracle :: ConditionedValueAbstractionVector -> IO (Maybe SolvedValueAbstractionVector) 30 | runSingleVectorOracle cvav = do 31 | let oracle = myOracle 32 | satisfiable <- queryOracle oracle cvav 33 | case satisfiable of 34 | DefinitelyUnsatisfiable -> return Nothing 35 | DontReallyKnow -> return $ Just $ SolvedValueAbstractionVector (valueAbstraction cvav) Nothing 36 | DefinitelySatisfiable be model -> return $ Just $ SolvedValueAbstractionVector (valueAbstraction cvav) (Just (be, model)) 37 | 38 | 39 | trivialOracle :: Oracle 40 | trivialOracle = Oracle (\_ -> return DontReallyKnow) 41 | 42 | 43 | -- FIXME This whole thing is unsound. For each constraint we need to set it to Unsat, Sat, or Dunno, and then only leave a constraint if it is definitely unsat. 44 | myOracle :: Oracle 45 | myOracle = Oracle { queryOracle = oracleOracleIsThisConditionedValueAbstractionVectorSatisfiable } 46 | 47 | -- Mirror, mirror, on the wall, ... 48 | oracleOracleIsThisConditionedValueAbstractionVectorSatisfiable :: ConditionedValueAbstractionVector -> IO OracleResult 49 | oracleOracleIsThisConditionedValueAbstractionVectorSatisfiable (CVAV _ {-gamma-}_ delta) = do 50 | let firstRound = resolveBottoms $ resolveVariableEqualities $ termConstraints delta 51 | if any isBottom firstRound 52 | then return DefinitelyUnsatisfiable 53 | else do 54 | let cs = firstRound 55 | -- We solve term constraints first 56 | if not (sattable cs) 57 | then return DontReallyKnow 58 | else do 59 | let bes = map convertToBoolE cs 60 | let be = foldl (BoolOp BoolAnd) (LitBool True) bes 61 | SatResult satResult <- boolESatResult $ BoolOp BoolEQ (LitBool True) be 62 | case satResult of 63 | Unsatisfiable _ -> return DefinitelyUnsatisfiable 64 | Unknown _ _ -> return DontReallyKnow 65 | ProofError _ _ -> return DontReallyKnow 66 | TimeOut _ -> return DontReallyKnow 67 | Satisfiable _ model -> 68 | -- Only if term constraints are definitely satisfiable, then we solve type constraints 69 | -- Currently we only do trivial type constraint checking 70 | return $ if null $ resolveTrivialTypeEqualities $ typeConstraints delta 71 | then DefinitelySatisfiable bes model 72 | else DontReallyKnow 73 | 74 | -- The most literal translation possible, for now. 75 | convertToBoolE :: Constraint -> BoolE 76 | convertToBoolE (IsBottom _) = error "cannot occur as per 'not (sattable cs)'" 77 | convertToBoolE (VarsEqual v1 v2) = BoolOp BoolEQ (BoolVar v1) (BoolVar v2) 78 | convertToBoolE (VarEqualsBool v be) = BoolOp BoolEQ (BoolVar v) be 79 | convertToBoolE (VarEqualsCons v "True" []) = BoolOp BoolEQ (BoolVar v) (LitBool True) 80 | convertToBoolE (VarEqualsCons v "False" []) = BoolOp BoolEQ (BoolVar v) (LitBool False) 81 | convertToBoolE (VarEqualsCons _ _ _) = error "cannot occur either" 82 | convertToBoolE (Uncheckable _) = error "cannot occur either" 83 | convertToBoolE (VarEqualsPat _ _) = error "cannot occur" 84 | 85 | resolveSatBools :: [Constraint] -> IO SatResult 86 | resolveSatBools cs 87 | | not (sattable cs) = return $ SatResult (Unknown undefined undefined) -- It should have been sattable by now 88 | | otherwise = do 89 | let clauses = map convertToBoolE cs 90 | let be = foldl (BoolOp BoolAnd) (LitBool True) clauses 91 | boolESatResult $ BoolOp BoolEQ (LitBool True) be 92 | 93 | 94 | 95 | sattable :: [Constraint] -> Bool 96 | sattable = all convertibleToSat 97 | where 98 | convertibleToSat (IsBottom _) = False 99 | convertibleToSat (VarsEqual _ _) = True 100 | convertibleToSat (VarEqualsBool _ _) = True 101 | convertibleToSat (VarEqualsCons _ "True" []) = True 102 | convertibleToSat (VarEqualsCons _ "False" []) = True 103 | convertibleToSat (VarEqualsCons _ _ _) = False 104 | convertibleToSat (VarEqualsPat _ _) = False 105 | convertibleToSat (Uncheckable _) = False 106 | 107 | isVarsEqualBoolConstraint :: Constraint -> Bool 108 | isVarsEqualBoolConstraint (VarEqualsBool _ _) = True 109 | isVarsEqualBoolConstraint _ = False 110 | 111 | resolveTrivialTypeEqualities :: [TypeConstraint] -> [TypeConstraint] 112 | resolveTrivialTypeEqualities = filter (uncurry (/=)) 113 | 114 | -- | Resolve variable equalities 115 | -- That is, for every @VarsEqual v1 v2@, replace all occurrences of v2 with v1 in all the other constraints 116 | resolveVariableEqualities :: [Constraint] -> [Constraint] 117 | resolveVariableEqualities [] = [] 118 | resolveVariableEqualities vs 119 | = case find isVarEquality vs of 120 | Nothing -> vs 121 | Just c@(VarsEqual v1 v2) -> 122 | let filtered = filter (/= c) vs 123 | in resolveVariableEqualities $ replaceVars v1 v2 filtered 124 | _ -> error "cannot occur as per 'isVarEquality'." 125 | where 126 | isVarEquality (VarsEqual _ _) = True 127 | isVarEquality _ = False 128 | 129 | replaceVars v1 v2 = map $ replaceVar v1 v2 130 | replaceVar :: Name -> Name -> (Constraint -> Constraint) 131 | replaceVar v1 v2 = mapVarConstraint (\v -> if v == v1 then v2 else v) 132 | 133 | -- | Figure out whether the bottoms are satisfiable 134 | -- That is, for every @IsBottom var@ constraint, it is satisfiable if @var@ does not occur in other constraints. 135 | -- 136 | -- This only works on lists that already have variables resolved 137 | resolveBottoms :: [Constraint] -> [Constraint] 138 | resolveBottoms cs = 139 | case find isBottom cs of 140 | Nothing -> cs 141 | Just c@(IsBottom var) -> do 142 | let filtered = filter (/= c) cs 143 | if otherOccurrenceOf var filtered 144 | then c : resolveBottoms filtered 145 | else resolveBottoms filtered 146 | _ -> error "cannot occur as per 'isBottom'." 147 | 148 | isBottom :: Constraint -> Bool 149 | isBottom (IsBottom _) = True 150 | isBottom _ = False 151 | 152 | otherOccurrenceOf :: Name -> [Constraint] -> Bool 153 | otherOccurrenceOf var = any occurrence 154 | where 155 | occurrence (Uncheckable _) = False 156 | occurrence (VarsEqual ovar1 ovar2) 157 | | ovar1 == var || ovar2 == var = True 158 | | otherwise = False 159 | occurrence (IsBottom ovar) 160 | | ovar == var = True 161 | | otherwise = False 162 | occurrence (VarEqualsBool ovar _) 163 | | ovar == var = True 164 | | otherwise = False 165 | occurrence (VarEqualsCons ovar _ _) 166 | | ovar == var = True 167 | | otherwise = False 168 | occurrence (VarEqualsPat ovar _) 169 | | ovar == var = True 170 | | otherwise = False 171 | 172 | 173 | -- TODO move these to Oracle.Utils 174 | 175 | mapVarConstraint :: (Name -> Name) -> Constraint -> Constraint 176 | -- mapVarConstraint f (BoolExp be) = BoolExp $ mapVarBE f be 177 | mapVarConstraint f (IsBottom var) = IsBottom $ f var 178 | mapVarConstraint f (VarsEqual v1 v2) = VarsEqual (f v1) (f v2) 179 | mapVarConstraint f (VarEqualsBool n be) = VarEqualsBool (f n) (mapVarBE f be) 180 | mapVarConstraint f (VarEqualsCons n1 n2 ps) = VarEqualsCons (f n1) n2 ps 181 | mapVarConstraint f (VarEqualsPat n p) = VarEqualsPat (f n) p 182 | mapVarConstraint _ uc@(Uncheckable _) = uc 183 | 184 | mapVarBE :: (Name -> Name) -> BoolE -> BoolE 185 | mapVarBE _ b@(LitBool _) = b 186 | mapVarBE _ Otherwise = Otherwise 187 | mapVarBE f (BoolVar var) = BoolVar $ f var 188 | mapVarBE f (BoolNot bn) = BoolNot $ mapVarBE f bn 189 | mapVarBE f (BoolOp bo be1 be2) = BoolOp bo (mapVarBE f be1) (mapVarBE f be2) 190 | mapVarBE f (IntBoolOp ibo ie1 ie2) = IntBoolOp ibo (mapVarIE f ie1) (mapVarIE f ie2) 191 | 192 | mapVarIE :: (Name -> Name) -> IntE -> IntE 193 | mapVarIE _ i@(IntLit _) = i 194 | mapVarIE f (IntVar v) = IntVar $ f v 195 | mapVarIE f (IntUnOp IntNeg ie) = IntUnOp IntNeg $ mapVarIE f ie 196 | mapVarIE f (IntOp io ie1 ie2) = IntOp io (mapVarIE f ie1) (mapVarIE f ie2) 197 | 198 | -------------------------------------------------------------------------------- /src/Oracle/SBVQueries.hs: -------------------------------------------------------------------------------- 1 | module Oracle.SBVQueries where 2 | 3 | import Control.Monad.State (StateT, evalStateT, gets, modify) 4 | import Control.Monad.Trans.Class (MonadTrans (..)) 5 | import Data.SBV 6 | import DataDefs 7 | 8 | 9 | -- boolESat :: BoolE -> IO Bool 10 | -- boolESat b = do 11 | -- SatResult result <- boolESatResult b 12 | -- case result of 13 | -- -- Overapproximation as per section 6.1 -- unless we can prove it unsatisfiable, we must 14 | -- -- assume it may match 15 | -- Unsatisfiable _ -> return False 16 | -- _ -> return True 17 | 18 | boolESatResult :: BoolE -> IO SatResult 19 | boolESatResult b = sat $ flip evalStateT initState $ buildSBool b 20 | where 21 | initState = SBuilderState { boolVars = [], integerVars = [] } -- , realVars = []} 22 | 23 | 24 | buildSBool :: BoolE -> SymbolicBuilder SBool 25 | buildSBool (LitBool True) = return true 26 | buildSBool (LitBool False) = return false 27 | buildSBool Otherwise = return true 28 | buildSBool (BoolVar v) = boolVar v 29 | buildSBool (BoolNot be) = bnot <$> buildSBool be 30 | buildSBool (BoolOp bo bv1 bv2) = do 31 | b1 <- buildSBool bv1 32 | b2 <- buildSBool bv2 33 | let o = case bo of 34 | BoolAnd -> (&&&) 35 | BoolOr -> (|||) 36 | BoolEQ -> (<=>) 37 | BoolNEQ -> (<+>) 38 | return $ b1 `o` b2 39 | 40 | buildSBool (IntBoolOp op ie1 ie2) = do 41 | i1 <- buildSInt ie1 42 | i2 <- buildSInt ie2 43 | let o = case op of 44 | IntLT -> (.<) 45 | IntLE -> (.<=) 46 | IntGT -> (.>) 47 | IntGE -> (.>=) 48 | IntEQ -> (.==) 49 | IntNEQ -> (./=) 50 | return $ i1 `o` i2 51 | 52 | -- buildSBool (FracBoolOp op fe1 fe2) = do 53 | -- f1 <- buildSFrac fe1 54 | -- f2 <- buildSFrac fe2 55 | -- let o = case op of 56 | -- FracLT -> (.<) 57 | -- FracLE -> (.<=) 58 | -- FracGT -> (.>) 59 | -- FracGE -> (.>=) 60 | -- FracEQ -> (.==) 61 | -- FracNEQ -> (./=) 62 | -- return $ f1 `o` f2 63 | 64 | buildSInt :: IntE -> SymbolicBuilder SInteger 65 | buildSInt (IntLit i) = return $ literal i 66 | buildSInt (IntVar v) = integerVar v 67 | buildSInt (IntUnOp IntNeg i) = do 68 | si <- buildSInt i 69 | return $ - si 70 | buildSInt (IntOp io iv1 iv2) = do 71 | i1 <- buildSInt iv1 72 | i2 <- buildSInt iv2 73 | let o = case io of 74 | IntPlus -> (+) 75 | IntTimes -> (*) 76 | IntMinus -> (-) 77 | IntDiv -> sDiv 78 | IntMod -> sMod 79 | return $ i1 `o` i2 80 | 81 | -- buildSFrac :: FracE -> SymbolicBuilder SDouble 82 | -- buildSFrac (FracLit f) = return $ literal $ fromRational f 83 | -- buildSFrac (FracVar v) = realVar v 84 | -- buildSFrac (FracUnOp FracNeg f) = do 85 | -- sf <- buildSFrac f 86 | -- return $ - sf 87 | -- buildSFrac (FracOp fo fv1 fv2) = do 88 | -- f1 <- buildSFrac fv1 89 | -- f2 <- buildSFrac fv2 90 | -- let o = case fo of 91 | -- FracPlus -> (+) 92 | -- FracTimes -> (*) 93 | -- FracMinus -> (-) 94 | -- FracDiv -> fpDiv $ literal RoundNearestTiesToEven 95 | -- return $ f1 `o` f2 96 | 97 | varsInBE :: BoolE -> [Name] 98 | varsInBE (LitBool _) = [] 99 | varsInBE (BoolNot be) = varsInBE be 100 | varsInBE (BoolOp _ be1 be2) = varsInBE be1 ++ varsInBE be2 101 | varsInBE (IntBoolOp _ ie1 ie2) = varsInIE ie1 ++ varsInIE ie2 102 | -- varsInBE (FracBoolOp _ fe1 fe2) = varsInFE fe1 ++ varsInFE fe2 103 | varsInBE (BoolVar var) = [var] 104 | varsInBE Otherwise = [] 105 | 106 | varsInIE :: IntE -> [Name] 107 | varsInIE (IntLit _) = [] 108 | varsInIE (IntUnOp _ ie) = varsInIE ie 109 | varsInIE (IntOp _ ie1 ie2) = varsInIE ie1 ++ varsInIE ie2 110 | varsInIE (IntVar var) = [var] 111 | 112 | -- varsInFE :: FracE -> [Name] 113 | -- varsInFE (FracLit _) = [] 114 | -- varsInFE (FracUnOp _ fe) = varsInFE fe 115 | -- varsInFE (FracOp _ fe1 fe2) = varsInFE fe1 ++ varsInFE fe2 116 | -- varsInFE (FracVar var) = [var] 117 | 118 | 119 | type SymbolicBuilder = StateT SBuilderState Symbolic 120 | 121 | data SBuilderState = SBuilderState 122 | { boolVars :: [(String, SBool)] 123 | , integerVars :: [(String, SInteger)] 124 | -- , realVars :: [(String, SDouble)] 125 | } 126 | 127 | boolVar :: String -> SymbolicBuilder SBool 128 | boolVar = lookupVar boolVars sBool (\name v -> modify (\s -> s { boolVars = (name, v) : boolVars s } ) ) 129 | 130 | integerVar :: String -> SymbolicBuilder SInteger 131 | integerVar = lookupVar integerVars sInteger (\name v -> modify (\s -> s { integerVars = (name, v) : integerVars s } ) ) 132 | 133 | -- realVar :: String -> SymbolicBuilder SDouble 134 | -- realVar = lookupVar realVars sDouble (\name v -> modify (\s -> s { realVars = (name, v) : realVars s } ) ) 135 | 136 | lookupVar :: (SBuilderState -> [(String, a)]) -- To lookup 137 | -> (String -> Symbolic a) -- To generate a new one if there isn't one yet 138 | -> (String -> a -> SymbolicBuilder ()) -- To add the var after generation, because record accessors cannot be passed around, apparently 139 | -> String -> SymbolicBuilder a 140 | lookupVar func genFunc update name = do 141 | bvs <- gets func 142 | case lookup name bvs of 143 | Nothing -> do 144 | bv <- lift $ genFunc name 145 | update name bv 146 | return bv 147 | Just sb -> return sb 148 | 149 | -------------------------------------------------------------------------------- /src/TH.hs: -------------------------------------------------------------------------------- 1 | module TH where 2 | 3 | import Language.Haskell.TH 4 | import Language.Haskell.TH.Quote 5 | 6 | literally :: String -> Q Exp 7 | literally = return . LitE . StringL 8 | 9 | lit :: QuasiQuoter 10 | lit = QuasiQuoter { quoteExp = literally, quotePat = undefined, quoteType = undefined, quoteDec = undefined } 11 | 12 | litFile :: QuasiQuoter 13 | litFile = quoteFile lit 14 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Types where 4 | 5 | import Control.Monad.Except 6 | import Control.Monad.Reader 7 | import Control.Monad.State 8 | 9 | import Data.Aeson (FromJSON, ToJSON) 10 | import Data.SBV.Internals (SMTModel (..)) 11 | import GHC.Generics (Generic) 12 | 13 | import DataDefs 14 | import qualified Language.Haskell.Exts as H 15 | 16 | data AnalysisAssigment 17 | = AnalysisAssigment 18 | FilePath 19 | H.Module 20 | deriving (Show, Eq) 21 | 22 | data AnalysisResult 23 | = AnalysisError [AnalysisError] 24 | | AnalysisSuccess [Recommendation] [Evaluatedness] 25 | deriving (Show, Eq, Generic) 26 | 27 | instance ToJSON AnalysisResult 28 | instance FromJSON AnalysisResult 29 | 30 | data Recommendation 31 | = Recommendation 32 | Name -- ^ Function name 33 | RecommendationReason 34 | deriving (Show, Eq, Generic) 35 | 36 | instance ToJSON Recommendation 37 | instance FromJSON Recommendation 38 | 39 | data RecommendationReason 40 | = NonExhaustive [(Clause, String)] -- Missing clause, namely these (and a set of constraints with its SAT model) 41 | | Redundant Clause -- Redundant Clause 42 | | InaccessibleRhs Clause -- Clause with inaccessible right-hand side 43 | deriving (Show, Eq, Generic) 44 | 45 | instance ToJSON RecommendationReason 46 | instance FromJSON RecommendationReason 47 | 48 | data AnalysisError 49 | = GatherError GatherError -- ^ Something went wrong while scraping functions 50 | | ProcessError AnalyzerError -- ^ Something went wrong during clause processing 51 | deriving (Show, Eq, Generic) 52 | 53 | instance ToJSON AnalysisError 54 | instance FromJSON AnalysisError 55 | 56 | type GatherError = String 57 | 58 | data FunctionTarget 59 | = FunctionTarget Function 60 | -- TODO add SrcLoc for printing later 61 | deriving (Show, Eq, Generic) 62 | 63 | instance ToJSON FunctionTarget 64 | instance FromJSON FunctionTarget 65 | 66 | -- TODO rename to intermediate function result 67 | data FunctionResult 68 | = FunctionResult ExecutionTrace 69 | deriving (Show, Eq, Generic) 70 | 71 | type ExecutionTrace = [ClauseCoverage] 72 | 73 | -- TODO rename to Function result once the todo on line 65 is resolved 74 | data SolvedFunctionResult 75 | = SolvedFunctionResult SolvedExecutionTrace 76 | deriving (Show, Generic) 77 | 78 | type SolvedExecutionTrace = [SolvedClauseCoverage] 79 | 80 | data ClauseCoverage = ClauseCoverage 81 | { capC :: ConditionedValueAbstractionSet 82 | , capU :: ConditionedValueAbstractionSet 83 | , capD :: ConditionedValueAbstractionSet 84 | } deriving (Show, Eq, Generic) 85 | 86 | data SolvedClauseCoverage = SolvedClauseCoverage 87 | { scapC :: SolvedValueAbstractionSet 88 | , scapU :: SolvedValueAbstractionSet 89 | , scapD :: SolvedValueAbstractionSet 90 | } deriving (Show, Generic) 91 | 92 | type SolvedValueAbstractionSet = [SolvedValueAbstractionVector] 93 | 94 | data SolvedValueAbstractionVector 95 | = SolvedValueAbstractionVector 96 | { svav :: ValueAbstractionVector 97 | , mmodel :: Maybe ([BoolE], SMTModel) 98 | } deriving (Show, Generic) 99 | 100 | 101 | type Analyzer = ExceptT AnalyzerError (StateT AnalyzerState (Reader AnalyzerContext)) 102 | type EvaluatednessAnalyzer = ExceptT AnalyzerError (Reader AnalyzerContext) 103 | 104 | data AnalyzerError 105 | = TypeNotFound String 106 | | VariableNotBound String 107 | | ConstructorNotFound String -- TODO make these two better than strings 108 | | UnpredictedError String 109 | deriving (Show, Eq, Generic) 110 | 111 | instance ToJSON AnalyzerError 112 | instance FromJSON AnalyzerError 113 | 114 | data AnalyzerState 115 | = AnalyzerState 116 | { nextFreshVarName :: Int -- ^ To generate fresh variable names 117 | } 118 | 119 | type AnalyzerContext = TypeUniverse 120 | 121 | 122 | data OracleResult 123 | = DefinitelySatisfiable [BoolE] SMTModel 124 | | DefinitelyUnsatisfiable 125 | | DontReallyKnow 126 | deriving (Show) 127 | 128 | data Evaluatedness 129 | = Evaluatedness 130 | Name -- ^ Name of the function 131 | [ -- ^ For a list of (exhaustive) ValueAbstractionVectors 132 | (ValueAbstractionVector 133 | , [ -- ^ For each argument, a pattern representing how it input will be evaluated 134 | Pattern 135 | ] 136 | ) 137 | ] 138 | deriving (Show, Eq, Generic) 139 | 140 | instance FromJSON Evaluatedness 141 | instance ToJSON Evaluatedness 142 | 143 | -------------------------------------------------------------------------------- /src/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Util where 5 | 6 | import qualified Data.Map as Map 7 | import OptParse.Types 8 | 9 | import Control.Monad (when) 10 | import Control.Monad.IO.Class 11 | import Control.Monad.Reader (MonadReader (..), asks) 12 | import qualified Text.Show.Pretty as Pr 13 | 14 | 15 | -- | Invert mapping. Used to construct inverse of getTypeConstructorsMap that will be used 16 | -- | to annotate ConstructorPattern arguments to be compatible with PatternVector 17 | invertMap :: (Ord b) => Map.Map a [b] -> Map.Map b a 18 | invertMap m = Map.fromList $ concatMap (\(k, vs) -> [(v, k) | v <- vs]) (Map.toList m) 19 | 20 | debug :: (MonadIO m, MonadReader Settings m) => String -> m () 21 | debug s = do 22 | debug <- asks setsDebug 23 | when debug $ liftIO $ putStrLn s 24 | 25 | debugShow :: (MonadIO m, MonadReader Settings m, Show s) => s -> m () 26 | debugShow = debug . Pr.ppShow 27 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | extra-package-dbs: [] 3 | packages: 4 | - '.' 5 | setup-info: 6 | ghc: 7 | linux64: 8 | 8.0.0.20160421: 9 | url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-deb8-linux.tar.xz 10 | sha1: 6e8bd7c96fa46da0b8c12bf9d62f006940adfe67 11 | macosx: 12 | 8.0.0.20160421: 13 | url: https://downloads.haskell.org/~ghc/8.0.1-rc4/ghc-8.0.0.20160421-x86_64-apple-darwin.tar.xz 14 | sha1: f1b60c26bd29f48e03f0881034bcaaa3d53b925f 15 | extra-deps: 16 | - HUnit-1.3.1.1 17 | - QuickCheck-2.8.2 18 | - aeson-0.11.1.4 19 | - aeson-pretty-0.7.2 20 | - ansi-terminal-0.6.2.3 21 | - ansi-wl-pprint-0.6.7.3 22 | - async-2.1.0 23 | - attoparsec-0.13.0.2 24 | - base-compat-0.9.1 25 | - cmdargs-0.10.14 26 | - cpphs-1.20.1 27 | - crackNum-1.5 28 | - data-binary-ieee754-0.4.4 29 | - dlist-0.7.1.2 30 | - fail-4.9.0.0 31 | - hashable-1.2.4.0 32 | - haskell-lexer-1.0 33 | - haskell-src-exts-1.17.1 34 | - hspec-2.2.3 35 | - hspec-core-2.2.3 36 | - hspec-discover-2.2.3 37 | - hspec-expectations-0.7.2 38 | - ieee754-0.7.8 39 | - mtl-2.2.1 40 | - old-locale-1.0.0.7 41 | - old-time-1.1.0.3 42 | - optparse-applicative-0.12.1.0 43 | - polyparse-1.12 44 | - pretty-show-1.6.9 45 | - primitive-0.6.1.0 46 | - quickcheck-io-0.1.2 47 | - random-1.1 48 | - sbv-5.12 49 | - scientific-0.3.4.6 50 | - setenv-0.1.1.3 51 | - stm-2.4.4.1 52 | - syb-0.6 53 | - tagged-0.8.4 54 | - text-1.2.2.1 55 | - tf-random-0.5 56 | - transformers-compat-0.5.1.4 57 | - unordered-containers-0.2.7.0 58 | - vector-0.11.0.0 59 | resolver: lts-7.24 60 | -------------------------------------------------------------------------------- /test/ClauseProcessingSpec.hs: -------------------------------------------------------------------------------- 1 | module ClauseProcessingSpec (spec) where 2 | 3 | import ClauseProcessing 4 | import Control.Monad.Except (runExceptT) 5 | import Control.Monad.Reader (runReader) 6 | import Control.Monad.State (evalStateT) 7 | import qualified Data.Set as S 8 | import DataDefs 9 | import Test.Hspec 10 | import Types 11 | 12 | runAnalyzer :: AnalyzerContext -> AnalyzerState -> Analyzer a -> Either AnalyzerError a 13 | runAnalyzer c s func = flip runReader c $ flip evalStateT s $ runExceptT $ func 14 | 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "freshVar" $ do 19 | it "should return variable pattern ~a when asked for the first fresh variable" $ do 20 | runAnalyzer (S.fromList []) (AnalyzerState 0) freshVar 21 | `shouldBe` Right (VariablePattern $ "~a") 22 | 23 | 24 | -------------------------------------------------------------------------------- /test/GathererSpec.hs: -------------------------------------------------------------------------------- 1 | module GathererSpec (spec) where 2 | 3 | import Data.Either (isLeft, isRight) 4 | import Gatherer 5 | import Language.Haskell.Exts (fromParseResult, parseFile) 6 | import Test.Hspec 7 | import TestUtils 8 | 9 | spec :: Spec 10 | spec = do 11 | blackBoxSpec 12 | 13 | blackBoxSpec :: Spec 14 | blackBoxSpec = describe "Black box tests" $ do 15 | blackBoxParseTests 16 | 17 | blackBoxParseTests :: Spec 18 | blackBoxParseTests = do 19 | describe "Parse tests" $ do 20 | describe "Expected successful parses" $ do 21 | forSourcesIn "data/exact" $ \fp -> do 22 | ast <- fromParseResult <$> parseFile fp 23 | getTypes ast `shouldSatisfy` isRight 24 | getFunctions ast `shouldSatisfy` isRight 25 | 26 | describe "Expected unsuccessful parses" $ do 27 | forSourcesIn "data/shouldNotParse" $ \fp -> do 28 | ast <- fromParseResult <$> parseFile fp 29 | let ress = (,) <$> getTypes ast <*> getFunctions ast 30 | ress `shouldSatisfy` isLeft 31 | 32 | -------------------------------------------------------------------------------- /test/LibSpec.hs: -------------------------------------------------------------------------------- 1 | module LibSpec (spec) where 2 | 3 | import Control.Monad (forM_) 4 | import Control.Monad.Reader (runReaderT) 5 | import Data.Aeson (eitherDecode) 6 | import qualified Data.ByteString.Lazy as LB 7 | import Lib 8 | import OptParse 9 | import System.Directory (doesFileExist) 10 | import Test.Hspec 11 | import TestUtils 12 | 13 | spec :: Spec 14 | spec = do 15 | blackBoxSpec 16 | 17 | blackBoxSpec :: Spec 18 | blackBoxSpec = describe "Black box tests" $ do 19 | blackBoxExactTests 20 | 21 | resultFileFor :: FilePath -> FilePath 22 | resultFileFor fp = fp ++ ".expected" 23 | 24 | blackBoxExactTests :: Spec 25 | blackBoxExactTests = describe "Black box tests" $ do 26 | sfs <- runIO $ sourceFiles "data/exact" 27 | forM_ sfs $ \fp -> do 28 | let rfp = resultFileFor fp 29 | rfpexists <- runIO $ doesFileExist rfp 30 | it fp $ do 31 | if rfpexists 32 | then do 33 | eC <- LB.readFile rfp 34 | actual <- flip runReaderT defaultSettings $ processTarget fp 35 | Right actual `shouldBe` eitherDecode eC -- This implicitly checks that decoding succeeds. 36 | else 37 | pendingWith $ "results for " ++ fp ++ " are missing,\nCheck the result with 'cat " ++ fp ++ " && patterns " ++ fp ++ "'\nand generate the results with 'patterns dump-results " ++ fp ++ " > " ++ rfp ++ "'" 38 | -------------------------------------------------------------------------------- /test/MainTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | module MainTest where 3 | 4 | import qualified Spec 5 | import Test.Hspec.Formatters 6 | import Test.Hspec.Runner 7 | 8 | main :: IO () 9 | main = hspecWith defaultConfig {configFormatter = Just progress} Spec.spec 10 | 11 | 12 | -------------------------------------------------------------------------------- /test/Oracle/SBVQueriesSpec.hs: -------------------------------------------------------------------------------- 1 | module Oracle.SBVQueriesSpec (spec) where 2 | 3 | import DataDefs 4 | import Oracle.TestUtils 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | spec :: Spec 9 | spec = do 10 | describe "boolESat" $ do 11 | it "figures out that True is satisfiable" $ do 12 | shouldBeSatisfiable $ LitBool True 13 | 14 | it "figures out that False is unsatisfiable" $ do 15 | shouldBeUnsatisfiable $ LitBool False 16 | 17 | it "figures out that any single variable is satisfiable" $ do 18 | once $ property $ \s -> shouldBeSatisfiable $ BoolVar s 19 | 20 | it "figures out the correct answer to these 'not' queries" $ do 21 | shouldBeSatisfiable $ BoolNot (LitBool False) 22 | shouldBeUnsatisfiable $ BoolNot (LitBool True) 23 | shouldBeSatisfiable $ BoolNot (BoolVar "x") 24 | 25 | it "figures out that a boolean variable can't be both true and false" $ do 26 | shouldBeUnsatisfiable 27 | $ BoolOp BoolAnd (BoolOp BoolEQ (BoolVar "x") (LitBool True)) 28 | (BoolOp BoolEQ (BoolVar "x") (LitBool False)) 29 | 30 | it "figures out the correct answer to these 'or' queries" $ do 31 | shouldBeSatisfiable $ BoolOp BoolOr (LitBool False) (LitBool True) 32 | shouldBeUnsatisfiable $ BoolOp BoolOr (LitBool False) (LitBool False) 33 | shouldBeSatisfiable $ BoolOp BoolOr (LitBool False) (BoolVar "x") 34 | 35 | it "figures out the correct answer to these 'and' queries" $ do 36 | shouldBeSatisfiable $ BoolOp BoolAnd (LitBool True) (LitBool True) 37 | shouldBeUnsatisfiable $ BoolOp BoolAnd (LitBool True) (LitBool False) 38 | shouldBeSatisfiable $ BoolOp BoolAnd (LitBool True) (BoolVar "x") 39 | shouldBeUnsatisfiable $ BoolOp BoolAnd (BoolVar "x") (LitBool False) 40 | 41 | it "figures out the correct answer to these 'eq' queries" $ do 42 | shouldBeSatisfiable $ BoolOp BoolEQ (LitBool True) (LitBool True) 43 | shouldBeSatisfiable $ BoolOp BoolEQ (LitBool False) (LitBool False) 44 | shouldBeUnsatisfiable $ BoolOp BoolEQ (LitBool True) (LitBool False) 45 | shouldBeSatisfiable $ BoolOp BoolEQ (LitBool True) (BoolVar "x") 46 | shouldBeSatisfiable $ BoolOp BoolEQ (BoolVar "x") (LitBool False) 47 | 48 | it "figures out the correct answer to these 'neq' queries" $ do 49 | shouldBeSatisfiable $ BoolOp BoolNEQ (LitBool False) (LitBool True) 50 | shouldBeSatisfiable $ BoolOp BoolNEQ (LitBool True) (LitBool False) 51 | shouldBeUnsatisfiable $ BoolOp BoolNEQ (LitBool False) (LitBool False) 52 | shouldBeSatisfiable $ BoolOp BoolNEQ (LitBool True) (BoolVar "x") 53 | shouldBeSatisfiable $ BoolOp BoolNEQ (BoolVar "x") (LitBool False) 54 | 55 | it "figures out basic facts about literal integers" $ do 56 | once $ 57 | forAll arbitrary $ \i1 -> 58 | forAll arbitrary $ \i2 -> do 59 | IntBoolOp IntLT (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 < i2) 60 | IntBoolOp IntLE (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 <= i2) 61 | IntBoolOp IntGT (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 > i2) 62 | IntBoolOp IntGE (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 >= i2) 63 | IntBoolOp IntEQ (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 == i2) 64 | IntBoolOp IntNEQ (IntLit i1) (IntLit i2) `shouldResolveTo` (i1 /= i2) 65 | 66 | it "figures out that basic facts about a variable and a literal are always satisfiable" $ do 67 | once $ 68 | forAll arbitrary $ \il -> 69 | forAll arbitrary $ \iv -> do 70 | shouldBeSatisfiable $ IntBoolOp IntLT (IntLit il) (IntVar iv) 71 | shouldBeSatisfiable $ IntBoolOp IntLE (IntLit il) (IntVar iv) 72 | shouldBeSatisfiable $ IntBoolOp IntGT (IntLit il) (IntVar iv) 73 | shouldBeSatisfiable $ IntBoolOp IntGE (IntLit il) (IntVar iv) 74 | shouldBeSatisfiable $ IntBoolOp IntEQ (IntLit il) (IntVar iv) 75 | shouldBeSatisfiable $ IntBoolOp IntNEQ (IntLit il) (IntVar iv) 76 | 77 | -------------------------------------------------------------------------------- /test/Oracle/TestUtils.hs: -------------------------------------------------------------------------------- 1 | module Oracle.TestUtils where 2 | 3 | import Data.SBV hiding (forAll) 4 | import DataDefs 5 | import Oracle 6 | import Oracle.SBVQueries 7 | import Test.Hspec 8 | 9 | constraintsShouldBeSatisfiable :: [Constraint] -> IO () 10 | constraintsShouldBeSatisfiable cs = do 11 | res <- resolveSatBools cs 12 | case res of 13 | SatResult (Satisfiable _ _) -> return () 14 | r -> expectationFailure $ show cs ++ "have not been found to be satisfiable: " ++ show r 15 | 16 | constraintsShouldBeUnsatisfiable :: [Constraint] -> IO () 17 | constraintsShouldBeUnsatisfiable cs = do 18 | res <- resolveSatBools cs 19 | case res of 20 | SatResult (Unsatisfiable _) -> return () 21 | r -> expectationFailure $ show cs ++ "have not been found to be unsatisfiable: " ++ show r 22 | 23 | shouldBeSatisfiable :: BoolE -> IO () 24 | shouldBeSatisfiable b = do 25 | res <- boolESatResult b 26 | case res of 27 | SatResult (Satisfiable _ _) -> return () 28 | r -> expectationFailure $ show b ++ " has not been found to be satisfiable: " ++ show r 29 | 30 | shouldBeUnsatisfiable :: BoolE -> IO () 31 | shouldBeUnsatisfiable b = do 32 | res <- boolESatResult b 33 | case res of 34 | SatResult (Unsatisfiable _) -> return () 35 | r -> expectationFailure $ show b ++ " has not been found to be unsatisfiable:\n" ++ show r 36 | 37 | shouldResolveTo :: BoolE -> Bool -> IO () 38 | shouldResolveTo be True = shouldBeSatisfiable be 39 | shouldResolveTo be False = shouldBeUnsatisfiable be 40 | -------------------------------------------------------------------------------- /test/OracleSpec.hs: -------------------------------------------------------------------------------- 1 | module OracleSpec (spec) where 2 | 3 | import DataDefs 4 | import Oracle 5 | import Oracle.TestUtils 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "resolveTrivialTypeEqualities" $ do 12 | it "leaves empty lists alone" $ do 13 | resolveTrivialTypeEqualities [] `shouldBe` [] 14 | 15 | describe "resolveVaribleEqualities" $ do 16 | it "leaves empty lists alone" $ do 17 | resolveVariableEqualities [] `shouldBe` [] 18 | 19 | it "removes any single variable equality because that's definitely satisfiable" $ do 20 | property $ \(v1, v2) -> resolveVariableEqualities [VarsEqual v1 v2] `shouldBe` [] 21 | 22 | it "removes all constraints if they only consist of variable equalities" $ do 23 | property $ \vts -> -- variable tuples 24 | resolveVariableEqualities (map (uncurry VarsEqual) vts) `shouldBe` [] 25 | 26 | it "correcly resolves this unit test" $ do 27 | resolveVariableEqualities 28 | [ IsBottom "x" 29 | , VarsEqual "x" "y" 30 | , VarEqualsBool "y" (BoolOp BoolOr (LitBool True) (BoolVar "y")) 31 | , VarsEqual "y" "z" 32 | , VarEqualsCons "z" "True" [] 33 | , Uncheckable "teehee" 34 | ] 35 | `shouldBe` 36 | [ IsBottom "z" 37 | , VarEqualsBool "z" (BoolOp BoolOr (LitBool True) (BoolVar "z")) 38 | , VarEqualsCons "z" "True" [] 39 | , Uncheckable "teehee" 40 | ] 41 | 42 | describe "resolveBottoms" $ do 43 | it "leaves empty lists alone" $ do 44 | resolveBottoms [] `shouldBe` [] 45 | 46 | it "removes any single IsBottom constraint because that's definitely satisfiable" $ do 47 | property $ \v -> resolveBottoms [IsBottom v] `shouldBe` [] 48 | 49 | 50 | describe "resolveSatBools" $ do 51 | it "says empty lists are satisfiable" $ do 52 | constraintsShouldBeSatisfiable [] 53 | 54 | it "correctly resolves this unit test" $ do 55 | constraintsShouldBeUnsatisfiable 56 | [ VarEqualsBool "x" (LitBool True) 57 | , VarEqualsBool "x" (LitBool False) 58 | ] 59 | 60 | -------------------------------------------------------------------------------- /test/TestUtils.hs: -------------------------------------------------------------------------------- 1 | module TestUtils where 2 | 3 | import Control.Monad (forM_) 4 | import System.Directory (doesDirectoryExist, listDirectory) 5 | import System.FilePath.Posix (takeExtension, ()) 6 | import Test.Hspec 7 | 8 | 9 | -- List the source files in a given directory 10 | sourceFiles :: FilePath -> IO [FilePath] 11 | sourceFiles dir = do 12 | direxists <- doesDirectoryExist dir 13 | if direxists 14 | then map (\f -> dir f) 15 | <$> filter (\f -> takeExtension f == ".hs") 16 | <$> listDirectory dir 17 | else return [] 18 | 19 | 20 | -- | Sets up a test case for every sourcefile in the given dir path 21 | forSourcesIn :: FilePath -> (FilePath -> IO ()) -> Spec 22 | forSourcesIn dir = forSourcesInDirs [dir] 23 | 24 | forSourcesInDirs :: [FilePath] -> (FilePath -> IO ()) -> Spec 25 | forSourcesInDirs dirs func = forM_ dirs $ \dir -> do 26 | sfs <- runIO $ sourceFiles dir 27 | forM_ sfs $ \fp -> it fp $ func fp 28 | 29 | --------------------------------------------------------------------------------