-
Notifications
You must be signed in to change notification settings - Fork 118
/
Oracle.hs
118 lines (96 loc) · 4.08 KB
/
Oracle.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
{-# LANGUAGE TypeFamilies, ConstraintKinds, ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable, TypeOperators, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Oracle(main) where
import Development.Shake
import Development.Shake.Classes
import Development.Shake.FilePath
import General.GetOpt
import Data.List.Extra
import Data.Tuple.Extra
import Test.Type hiding (RandomType)
import qualified Test.Type as T
import Control.Monad
import General.Extra
-- These are instances we'll compute over
type instance RuleResult String = String
type instance RuleResult Int = String
type instance RuleResult () = String
type instance RuleResult Bool = Bool -- test results don't have to be a boolean
newtype FileLen = FileLen FilePath
deriving (Eq,Show,NFData,Typeable,Hashable,Binary)
type instance RuleResult FileLen = Int
newtype RandomType = RandomType (BinarySentinel String)
deriving (Eq,Show,NFData,Typeable,Hashable,Binary)
type instance RuleResult RandomType = Int
type instance RuleResult T.RandomType = Int
data Define = Define String String -- this type produces this result
opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tailErr . breakOn "=") "type=value") ""]
main = testBuildArgs test opt $ \args -> do
addOracle $ \(T.RandomType _) -> pure 42
addOracle $ \(RandomType _) -> pure (-42)
"randomtype.txt" %> \out -> do
a <- askOracle $ T.RandomType $ BinarySentinel ()
b <- askOracle $ RandomType $ BinarySentinel ()
writeFile' out $ show (a,b)
addOracle $ \b -> pure $ not b
"true.txt" %> \out -> writeFile' out . show =<< askOracle False
let add :: forall a . (ShakeValue a, RuleResult a ~ String) => String -> a -> Rules ()
add name key = do
name <.> "txt" %> \out -> do
liftIO $ appendFile ".log" "."
writeFile' out =<< askOracle key
forM_ [val | Define nam val <- args, nam == name] $ \val ->
addOracle $ \(_ :: a) -> pure val
add "string" ""
add "unit" ()
add "int" (0 :: Int)
addOracleCache $ \(FileLen file) -> do
liftIO $ appendFile ".log" "#"
length <$> readFile' file
"cache_out.txt" %> \out -> do
o <- askOracle (FileLen "cache_in.txt")
liftIO $ appendFile ".log" "!"
writeFile' out $ show o
test build = do
build ["clean"]
build ["randomtype.txt"]
assertContents "randomtype.txt" "(42,-42)"
-- check it rebuilds when it should
writeFile ".log" ""
build ["--def=string=name","string.txt"]
assertContents "string.txt" "name"
build ["--def=string=name","string.txt"]
assertContents "string.txt" "name"
build ["--def=string=test","string.txt"]
assertContents "string.txt" "test"
assertContents ".log" ".."
-- check adding/removing redundant oracles does not trigger a rebuild
build ["--def=string=test","string.txt","--def=unit=bob"]
build ["--def=string=test","string.txt","--def=int=fred"]
build ["--def=string=test","string.txt"]
assertContents "string.txt" "test"
assertContents ".log" ".."
writeFile ".log" ""
writeFile "cache_in.txt" "aaa"
build ["cache_out.txt","--sleep"]
assertContents "cache_out.txt" "3"
assertContents ".log" "#!"
writeFile "cache_in.txt" "zzz"
build ["cache_out.txt","--sleep"]
build ["cache_out.txt","--sleep"]
assertContents "cache_out.txt" "3"
assertContents ".log" "#!#"
writeFile "cache_in.txt" "zzzz"
build ["cache_out.txt","--sleep"]
assertContents "cache_out.txt" "4"
assertContents ".log" "#!##!"
-- check error messages are good
let errors args err = assertExceptionAfter (replace "\\" "/") err $ build $ "--quiet" : args
build ["--def=unit=test","unit.txt"]
errors ["unit.txt"] -- Building with an an Oracle that has been removed
["missing a call to addOracle"]
errors ["int.txt"] -- Building with an Oracle that I know nothing about
["missing a call to addOracle"]
errors ["--def=string=1","--def=string=1"] -- Two Oracles defined in one go
["oracle defined twice", "Test/Oracle.hs"]