-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathCommon.hs
171 lines (140 loc) · 4.13 KB
/
Common.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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
module Common
( module Common
, module Lenses
, module T
) where
import Control.Monad as T (unless, when)
import Control.Monad.Catch as T (catch)
import Control.Monad.IO.Class as T (MonadIO, liftIO)
import qualified Control.Lens as Lenses
import Data.Function (on)
import Data.Hashable (Hashable, hash)
import Data.List (nubBy, sortBy)
import Data.Ord (comparing)
import Data.Relation (Relates)
import Data.String (IsString)
import Data.Union (Member (..))
import Generic.Random
import GHC.Generics (Generic)
import Test.Hspec as T
import Test.QuickCheck as T
( Arbitrary (..)
, Gen
, Property
, Testable
, elements
, forAll
, ioProperty
, property
, (===)
, (==>)
)
import Test.QuickCheck.Instances as T ()
import qualified Data.Tree.AVL as AVL
import qualified Data.Tree.AVL.Store.Pure as Pure
import qualified Data.Tree.AVL.Store.Void as Void
type Layer = AVL.Rep IntHash StringName Int
instance Hashable a => AVL.ProvidesHash a IntHash where
getHash = IntHash . hash
newtype IntHash = IntHash { getIntHash :: Int }
deriving stock (Eq, Ord)
deriving newtype Hashable
instance Show IntHash where
show = take 8 . map convert . map (`mod` 16) . iterate (`div` 16) . abs . getIntHash
where
convert = ("0123456789ABCDEF" !!)
newtype StringName = StringName { getStringName :: String }
deriving stock (Eq, Ord)
deriving newtype Hashable
deriving IsString via String
instance Show StringName where
show = getStringName
instance Arbitrary StringName where
arbitrary = do
a <- elements ['B'.. 'Y']
return (StringName [a])
data UKey
= K1 StringName
| K2 Bool
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Hashable)
instance Arbitrary UKey where
arbitrary = genericArbitraryU
data UValue
= V1 Int
| V2 String
deriving stock (Eq, Ord, Show, Generic)
deriving anyclass (Hashable)
instance Arbitrary UValue where
arbitrary = genericArbitraryU
instance Relates StringName Int
instance Relates Bool String
Lenses.makePrisms ''UKey
Lenses.makePrisms ''UValue
instance Member StringName UKey where union = _K1
instance Member Bool UKey where union = _K2
instance Member Int UValue where union = _V1
instance Member String UValue where union = _V2
type StorageMonad = Void.Store IntHash StringName Int
type StorageMonad' = Pure.StoreT IntHash StringName Int StorageMonad
type M = AVL.Map IntHash StringName Int
type UStorageMonad = Void.Store IntHash UKey UValue
type UStorageMonad' = Pure.StoreT IntHash UKey UValue UStorageMonad
scanM :: Monad m => (a -> b -> m b) -> b -> [a] -> m [b]
scanM _ _ [] = return []
scanM action accum (x : xs) = do
(accum :) <$> do
accum' <- action x accum
scanM action accum' xs
unique :: Eq a => [(a, b)] -> [(a, b)]
unique = nubBy ((==) `on` fst)
uniqued :: Ord a => [(a, b)] -> [(a, b)]
uniqued = sortBy (comparing fst) . unique . reverse
it'
:: ( Testable (f Property)
, Testable prop
, Functor f
)
=> String
-> f (StorageMonad prop)
-> SpecWith ()
it' msg func =
it msg $ property $ fmap (ioProperty . Void.runStoreT) func
it''
:: ( Testable prop
, Arbitrary src
, Show src
)
=> String
-> (src -> StorageMonad' prop)
-> SpecWith ()
it'' msg func =
it msg $ property $ \src ->
ioProperty $ Void.runStoreT $ do
st <- Pure.newState
Pure.runStoreT st (func src)
uit'
:: ( Testable (f Property)
, Testable prop
, Functor f
)
=> String
-> f (UStorageMonad prop)
-> SpecWith ()
uit' msg func =
it msg $ property $ fmap (ioProperty . Void.runStoreT) func
uit''
:: ( Testable prop
, Arbitrary src
, Show src
)
=> String
-> (src -> UStorageMonad' prop)
-> SpecWith ()
uit'' msg func =
it msg $ property $ \src ->
ioProperty $ Void.runStoreT $ do
st <- Pure.newState
Pure.runStoreT st (func src)
put :: (MonadIO m) => String -> m ()
put = liftIO . putStrLn