differentially validate coverage witnesses and compiled dispatch
This commit is contained in:
11 files changed
+737
No files matched your search
+249
@@ -0,0 +1,249 @@
|
||||
module Main where
|
||||
|
||||
import Data.List (isInfixOf)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
|
||||
import Tessera.Analyze
|
||||
import Tessera.Check (checkProgram)
|
||||
import Tessera.Env
|
||||
import Tessera.Eval
|
||||
import Tessera.Matrix
|
||||
import Tessera.Parser (parseExpression, parseProgram)
|
||||
import Tessera.Serialize
|
||||
import Tessera.Syntax
|
||||
import Tessera.Tree
|
||||
|
||||
type Result = (String, Bool)
|
||||
|
||||
parseOk :: String -> Program
|
||||
parseOk source = case parseProgram source of
|
||||
Left diagnostic -> error ("parse failed: " ++ show diagnostic)
|
||||
Right program -> program
|
||||
|
||||
envOk :: Program -> Env
|
||||
envOk program = case checkProgram program of
|
||||
Left diagnostic -> error ("check failed: " ++ show diagnostic)
|
||||
Right env -> env
|
||||
|
||||
envSource :: String -> Env
|
||||
envSource = envOk . parseOk
|
||||
|
||||
aritiesOf :: Env -> [(String, Int)]
|
||||
aritiesOf env = Map.toList (Map.map (length . snd) (envConstructorTypes env))
|
||||
|
||||
valueOf :: Env -> String -> Value
|
||||
valueOf env text = case parseExpression (aritiesOf env) text of
|
||||
Left diagnostic -> error ("value parse failed: " ++ show diagnostic)
|
||||
Right expression -> case evalExpr env Map.empty expression of
|
||||
Left message -> error ("value eval failed: " ++ message)
|
||||
Right value -> value
|
||||
|
||||
matchOf :: String -> Program -> Declaration
|
||||
matchOf name program = case [m | m@(MatchDeclaration n _ _ _) <- program, n == name] of
|
||||
(m : _) -> m
|
||||
[] -> error ("no match " ++ name)
|
||||
|
||||
treeOf :: Env -> Strategy -> Declaration -> Tree
|
||||
treeOf env strategy (MatchDeclaration _ arguments _ clauses) =
|
||||
compileMatch env strategy (map snd arguments) (zip (map clausePatterns clauses) [0 .. length clauses - 1]) (initialOccurrences (length arguments))
|
||||
treeOf _ _ _ = Failure
|
||||
|
||||
boolType :: Type
|
||||
boolType = TName "Bool" []
|
||||
|
||||
intType :: Type
|
||||
intType = TName "Int" []
|
||||
|
||||
listProgram :: Program
|
||||
listProgram = parseOk "data List a = Nil | Cons a (List a)\n"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let results = tests
|
||||
failures = [name | (name, ok) <- results, not ok]
|
||||
mapM_ (\(name, ok) -> putStrLn ((if ok then "ok " else "FAIL ") ++ name)) results
|
||||
putStrLn (show (length results - length failures) ++ "/" ++ show (length results) ++ " tests passed")
|
||||
if null failures then exitSuccess else exitFailure
|
||||
|
||||
tests :: [Result]
|
||||
tests =
|
||||
[ ("specialise expands constructor and wildcard rows", testSpecialise)
|
||||
, ("default matrix keeps wildcard rows only", testDefault)
|
||||
, ("boolean witness is the missing constructor", testBooleanWitness)
|
||||
, ("boolean coverage is exhaustive", testBooleanCoverage)
|
||||
, ("integer witness escapes the covered literals", testIntegerWitness)
|
||||
, ("multiple arguments detect cross column gaps", testMultipleArguments)
|
||||
, ("recursive list coverage is exhaustive", testRecursiveList)
|
||||
, ("uninhabited recursive type is vacuously exhaustive", testUninhabited)
|
||||
, ("variable binding and shadowing", testBinding)
|
||||
, ("source matcher agrees with compiled trees", testAgreement)
|
||||
, ("serialisation round trip preserves the tree", testRoundTrip)
|
||||
, ("malformed tree encoding is rejected", testMalformedTree)
|
||||
, ("unknown constructor in tree is rejected", testUnknownConstructor)
|
||||
, ("redundant clause is detected", testRedundant)
|
||||
, ("useful clause example selects its clause", testExample)
|
||||
, ("overlapping nested patterns", testOverlapping)
|
||||
, ("deterministic generated matches agree", testGenerated)
|
||||
]
|
||||
|
||||
testSpecialise :: Bool
|
||||
testSpecialise =
|
||||
let env = envOk listProgram
|
||||
listInt = TName "List" [intType]
|
||||
matrix = [[PCon "Cons" [PVar "x", PVar "xs"]], [PWild]]
|
||||
specialised = specialize env (KeyCon "Cons") matrix
|
||||
in length specialised == 2 && all ((== 2) . length) specialised
|
||||
|
||||
testDefault :: Bool
|
||||
testDefault =
|
||||
let env = envOk listProgram
|
||||
matrix = [[PCon "Cons" [PVar "x", PVar "xs"]], [PWild]]
|
||||
in defaultMatrix matrix == [[]] && Map.size (envConstructorTypes env) > 0
|
||||
|
||||
testBooleanWitness :: Bool
|
||||
testBooleanWitness =
|
||||
let env = envSource "data Flag = On | Off\n"
|
||||
outcome = witness env 100 [TName "Flag" []] [[PCon "On" []]]
|
||||
in case outcome of
|
||||
NotCovered [PCon "Off" []] -> True
|
||||
_ -> False
|
||||
|
||||
testBooleanCoverage :: Bool
|
||||
testBooleanCoverage =
|
||||
let env = envSource "data Flag = On | Off\n"
|
||||
outcome = witness env 100 [TName "Flag" []] [[PCon "On" []], [PCon "Off" []]]
|
||||
in outcome == Covered
|
||||
|
||||
testIntegerWitness :: Bool
|
||||
testIntegerWitness =
|
||||
let env = envSource "data Flag = On | Off\n"
|
||||
outcome = witness env 100 [intType] [[PInt 0], [PInt 1]]
|
||||
in case outcome of
|
||||
NotCovered [PInt n] -> n == 2
|
||||
_ -> False
|
||||
|
||||
testMultipleArguments :: Bool
|
||||
testMultipleArguments =
|
||||
let env = envSource "data Flag = On | Off\n"
|
||||
matrix = [[PCon "On" [], PCon "On" []], [PCon "On" [], PCon "Off" []], [PCon "Off" [], PCon "On" []]]
|
||||
outcome = witness env 200 [TName "Flag" [], TName "Flag" []] matrix
|
||||
in case outcome of
|
||||
NotCovered [PCon "Off" [], PCon "Off" []] -> True
|
||||
_ -> False
|
||||
|
||||
testRecursiveList :: Bool
|
||||
testRecursiveList =
|
||||
let env = envOk listProgram
|
||||
matrix = [[PCon "Nil" []], [PCon "Cons" [PWild, PWild]]]
|
||||
outcome = witness env 200 [TName "List" [intType]] matrix
|
||||
in outcome == Covered
|
||||
|
||||
testUninhabited :: Bool
|
||||
testUninhabited =
|
||||
let program = parseOk "data Loop = Loop Loop\n\nmatch spin (x : Loop) : Int =\n | Loop y -> 0\n"
|
||||
env = envOk program
|
||||
matrix = [[PCon "Loop" [PVar "y"]]]
|
||||
outcome = witness env 200 [TName "Loop" []] matrix
|
||||
inhabitants = finiteInhabitants env
|
||||
in outcome == Covered && Map.findWithDefault True "Loop" inhabitants == False
|
||||
|
||||
testBinding :: Bool
|
||||
testBinding =
|
||||
let program = parseOk "data Pair a b = MkPair a b\n\nmatch first (p : Pair Int Int) : Int =\n | MkPair x y -> x + y\n"
|
||||
env = envOk program
|
||||
match' = matchOf "first" program
|
||||
tree = treeOf env Leftmost match'
|
||||
value = valueOf env "MkPair 4 5"
|
||||
in evaluateCompiled env (matchClauses match') tree [value] == Right (VInt 9)
|
||||
&& evaluateSource env (matchClauses match') [value] == Right (VInt 9)
|
||||
|
||||
testAgreement :: Bool
|
||||
testAgreement =
|
||||
let program = parseOk "data Flag = On | Off\n\nmatch both (a : Flag) (b : Flag) : Int =\n | On On -> 1\n | On Off -> 2\n | Off On -> 3\n | Off Off -> 4\n"
|
||||
env = envOk program
|
||||
match' = matchOf "both" program
|
||||
clauses = matchClauses match'
|
||||
values = [ [valueOf env "On", valueOf env "On"]
|
||||
, [valueOf env "On", valueOf env "Off"]
|
||||
, [valueOf env "Off", valueOf env "On"]
|
||||
, [valueOf env "Off", valueOf env "Off"]
|
||||
]
|
||||
leftmost = treeOf env Leftmost match'
|
||||
heuristic = treeOf env Heuristic match'
|
||||
in all (\v -> evaluateSource env clauses v == evaluateCompiled env clauses leftmost v
|
||||
&& evaluateSource env clauses v == evaluateCompiled env clauses heuristic v) values
|
||||
|
||||
testRoundTrip :: Bool
|
||||
testRoundTrip =
|
||||
let source = "data Flag = On | Off\n\nmatch flag (f : Flag) : Int =\n | On -> 1\n | Off -> 0\n"
|
||||
program = parseOk source
|
||||
env = envOk program
|
||||
match' = matchOf "flag" program
|
||||
tree = treeOf env Heuristic match'
|
||||
encoded = encodeArtifact "flag" source Heuristic tree
|
||||
in case decodeArtifact encoded of
|
||||
Left _ -> False
|
||||
Right artifact -> artifactTree artifact == tree
|
||||
|
||||
testMalformedTree :: Bool
|
||||
testMalformedTree =
|
||||
case decodeArtifact "tessera-tree 1\nfunction x\ntree W[\nsource-begin\nsource-end\n" of
|
||||
Left _ -> True
|
||||
Right _ -> False
|
||||
|
||||
testUnknownConstructor :: Bool
|
||||
testUnknownConstructor =
|
||||
let source = "data Flag = On | Off\n\nmatch flag (f : Flag) : Int =\n | On -> 1\n | Off -> 0\n"
|
||||
encoded = "tessera-tree 1\nfunction flag\nstrategy leftmost\ntree W[0]{cNope:L0;}[X]\nsource-begin\n" ++ source ++ "source-end\n"
|
||||
in case decodeArtifact encoded of
|
||||
Left message -> "unknown constructor" `isInfixOf` message
|
||||
Right _ -> False
|
||||
|
||||
testRedundant :: Bool
|
||||
testRedundant =
|
||||
let program = parseOk "data Flag = On | Off\n\nmatch flag (f : Flag) : Int =\n | On -> 1\n | _ -> 0\n | Off -> 2\n"
|
||||
env = envOk program
|
||||
report = case analyzeMatch env (matchOf "flag" program) of
|
||||
Just r -> r
|
||||
Nothing -> error "no report"
|
||||
statuses = map reportClauseStatus (reportClauseReports report)
|
||||
in statuses == [ClauseUseful, ClauseUseful, ClauseRedundant]
|
||||
|
||||
testExample :: Bool
|
||||
testExample =
|
||||
let program = parseOk "data Flag = On | Off\n\nmatch flag (f : Flag) : Int =\n | On -> 1\n | Off -> 0\n"
|
||||
env = envOk program
|
||||
report = case analyzeMatch env (matchOf "flag" program) of
|
||||
Just r -> r
|
||||
Nothing -> error "no report"
|
||||
examples = [example | ClauseReport _ ClauseUseful (Just example) <- reportClauseReports report]
|
||||
in length examples == 2
|
||||
|
||||
testOverlapping :: Bool
|
||||
testOverlapping =
|
||||
let program = parseOk "data Option a = None | Some a\n\nmatch pick (o : Option Int) : Int =\n | Some x -> x\n | Some 0 -> 1\n | None -> 0\n"
|
||||
env = envOk program
|
||||
report = case analyzeMatch env (matchOf "pick" program) of
|
||||
Just r -> r
|
||||
Nothing -> error "no report"
|
||||
statuses = map reportClauseStatus (reportClauseReports report)
|
||||
in statuses == [ClauseUseful, ClauseRedundant, ClauseUseful]
|
||||
|
||||
testGenerated :: Bool
|
||||
testGenerated =
|
||||
let generated = [ "match f (a : Flag) (b : Flag) : Int =\n | " ++ renderPattern a ++ " " ++ renderPattern b ++ " -> 0\n"
|
||||
| (a, b) <- [(True, True), (True, False), (False, True)]
|
||||
]
|
||||
source = "data Flag = On | Off\n\n" ++ concat generated
|
||||
program = parseOk source
|
||||
env = envOk program
|
||||
match' = matchOf "f" program
|
||||
leftmost = treeOf env Leftmost match'
|
||||
heuristic = treeOf env Heuristic match'
|
||||
values = [[valueOf env "On", valueOf env "On"], [valueOf env "On", valueOf env "Off"], [valueOf env "Off", valueOf env "On"], [valueOf env "Off", valueOf env "Off"]]
|
||||
in all (\v -> evaluateCompiled env (matchClauses match') leftmost v == evaluateCompiled env (matchClauses match') heuristic v) values
|
||||
|
||||
renderPattern :: Bool -> String
|
||||
renderPattern True = "On"
|
||||
renderPattern False = "Off"
|
||||
Reference in new issue
Block a user