Skip to content

Commit 82504fc

Browse files
stevladimirstevladimir
committed
Add tests for Either
1 parent b5575b0 commit 82504fc

File tree

3 files changed

+267
-79
lines changed

3 files changed

+267
-79
lines changed

‎benchmarks/Generic/Either.hs‎

Lines changed: 73 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,73 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE TypeApplications #-}
5+
6+
module Generic.Either
7+
( EitherManual(..)
8+
, ManualEither0
9+
, ManualEither1
10+
, ManualEither2
11+
, ManualEither3
12+
, EitherGeneric(..)
13+
, GenericEither0
14+
, GenericEither1
15+
, GenericEither2
16+
, GenericEither3
17+
) where
18+
19+
import Control.DeepSeq
20+
import Data.Csv
21+
import Data.Proxy
22+
import Data.Typeable
23+
import GHC.Generics (Generic)
24+
25+
26+
data EitherManual a b = LManual a | RManual b
27+
deriving (Generic, NFData, Show, Typeable)
28+
29+
instance (FromField a, FromField b, Typeable a, Typeable b) => FromField (EitherManual a b) where
30+
parseField field = case runParser (parseField field) of
31+
Left _ -> case runParser (parseField field) of
32+
Left _ -> fail $ "Can't parse field of type "
33+
<> show (typeRep $ Proxy @(EitherManual a b)) <> " from " <> show field
34+
Right ok -> pure $ RManual ok
35+
Right ok -> pure $ LManual ok
36+
37+
instance (ToField a, ToField b) => ToField (EitherManual a b) where
38+
toField (LManual x) = toField x
39+
toField (RManual x) = toField x
40+
41+
data EitherGeneric a b = LGeneric a | RGeneric b
42+
deriving (Generic, NFData, Show, Typeable)
43+
44+
instance (FromField a, FromField b) => FromField (EitherGeneric a b)
45+
instance (ToField a, ToField b) => ToField (EitherGeneric a b)
46+
47+
type Either0 f = f Int Char
48+
type Either1 f = f (Either0 f) (Either0 f)
49+
type Either2 f = f (Either1 f) (Either1 f)
50+
type Either3 f = f (Either2 f) (Either2 f)
51+
type Either4 f = f (Either3 f) (Either3 f)
52+
type Either5 f = f (Either4 f) (Either4 f)
53+
type Either6 f = f (Either5 f) (Either5 f)
54+
type Either7 f = f (Either6 f) (Either6 f)
55+
type Either8 f = f (Either7 f) (Either7 f)
56+
type Either9 f = f (Either8 f) (Either8 f)
57+
type Either10 f = f (Either9 f) (Either9 f)
58+
type Either11 f = f (Either10 f) (Either10 f)
59+
type Either12 f = f (Either11 f) (Either11 f)
60+
type Either13 f = f (Either12 f) (Either12 f)
61+
type Either14 f = f (Either13 f) (Either13 f)
62+
type Either15 f = f (Either14 f) (Either14 f)
63+
type Either16 f = f (Either15 f) (Either15 f)
64+
65+
type ManualEither0 = Either0 EitherManual
66+
type ManualEither1 = Either1 EitherManual
67+
type ManualEither2 = Either2 EitherManual
68+
type ManualEither3 = Either3 EitherManual
69+
70+
type GenericEither0 = Either0 EitherGeneric
71+
type GenericEither1 = Either1 EitherGeneric
72+
type GenericEither2 = Either2 EitherGeneric
73+
type GenericEither3 = Either3 EitherGeneric

‎benchmarks/GenericFieldBench.hs‎

Lines changed: 190 additions & 79 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ import Criterion
1010
import Data.Csv
1111
import Data.Proxy
1212
import Data.Typeable
13+
import Generic.Either
1314
import Generic.U2
1415
import Generic.U4
1516
import Generic.U8
@@ -19,94 +20,204 @@ import Generic.U32
1920

2021
genericFieldBench :: Benchmark
2122
genericFieldBench = bgroup "genericField"
22-
[ bgroup "parseField: ok"
23-
[ mkParseSuccessBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix)
24-
, mkParseSuccessBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix)
25-
, mkParseSuccessBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix)
26-
, mkParseSuccessBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix)
27-
, mkParseSuccessBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix)
23+
[ bgroup "parseField:ok"
24+
[ mkParseSuccessBench (genRange @U2)
25+
, mkParseSuccessBench (genRange @U2Generic)
26+
, mkParseSuccessBench (genRange @U2GenericStripPrefix)
27+
, mkParseSuccessBench (genRange @U4)
28+
, mkParseSuccessBench (genRange @U4Generic)
29+
, mkParseSuccessBench (genRange @U4GenericStripPrefix)
30+
, mkParseSuccessBench (genRange @U8)
31+
, mkParseSuccessBench (genRange @U8Generic)
32+
, mkParseSuccessBench (genRange @U8GenericStripPrefix)
33+
, mkParseSuccessBench (genRange @U16)
34+
, mkParseSuccessBench (genRange @U16Generic)
35+
, mkParseSuccessBench (genRange @U16GenericStripPrefix)
36+
, mkParseSuccessBench (genRange @U32)
37+
, mkParseSuccessBench (genRange @U32Generic)
38+
, mkParseSuccessBench (genRange @U32GenericStripPrefix)
39+
, mkParseSuccessBench manualEither0
40+
, mkParseSuccessBench genericEither0
41+
, mkParseSuccessBench manualEither1
42+
, mkParseSuccessBench genericEither1
43+
, mkParseSuccessBench manualEither2
44+
, mkParseSuccessBench genericEither2
45+
, mkParseSuccessBench manualEither3
46+
, mkParseSuccessBench genericEither3
2847
]
29-
, bgroup "parseField: fail"
30-
[ mkParseFailBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix)
31-
, mkParseFailBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix)
32-
, mkParseFailBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix)
33-
, mkParseFailBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix)
34-
, mkParseFailBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix)
48+
, bgroup "parseField:fail"
49+
[ mkParseFailBench (Proxy @U2)
50+
, mkParseFailBench (Proxy @U2Generic)
51+
, mkParseFailBench (Proxy @U2GenericStripPrefix)
52+
, mkParseFailBench (Proxy @U4)
53+
, mkParseFailBench (Proxy @U4Generic)
54+
, mkParseFailBench (Proxy @U4GenericStripPrefix)
55+
, mkParseFailBench (Proxy @U8)
56+
, mkParseFailBench (Proxy @U8Generic)
57+
, mkParseFailBench (Proxy @U8GenericStripPrefix)
58+
, mkParseFailBench (Proxy @U16)
59+
, mkParseFailBench (Proxy @U16Generic)
60+
, mkParseFailBench (Proxy @U16GenericStripPrefix)
61+
, mkParseFailBench (Proxy @U32)
62+
, mkParseFailBench (Proxy @U32Generic)
63+
, mkParseFailBench (Proxy @U32GenericStripPrefix)
64+
, mkParseFailBench (Proxy @ManualEither0)
65+
, mkParseFailBench (Proxy @GenericEither0)
66+
, mkParseFailBench (Proxy @ManualEither1)
67+
, mkParseFailBench (Proxy @GenericEither1)
68+
, mkParseFailBench (Proxy @ManualEither2)
69+
, mkParseFailBench (Proxy @GenericEither2)
70+
, mkParseFailBench (Proxy @ManualEither3)
71+
, mkParseFailBench (Proxy @GenericEither3)
3572
]
3673
, bgroup "toField"
37-
[ mkToFieldBench (Proxy @U2) (Proxy @U2Generic) (Proxy @U2GenericStripPrefix)
38-
, mkToFieldBench (Proxy @U4) (Proxy @U4Generic) (Proxy @U4GenericStripPrefix)
39-
, mkToFieldBench (Proxy @U8) (Proxy @U8Generic) (Proxy @U8GenericStripPrefix)
40-
, mkToFieldBench (Proxy @U16) (Proxy @U16Generic) (Proxy @U16GenericStripPrefix)
41-
, mkToFieldBench (Proxy @U32) (Proxy @U32Generic) (Proxy @U32GenericStripPrefix)
74+
[ mkToFieldBench (genRange @U2)
75+
, mkToFieldBench (genRange @U2Generic)
76+
, mkToFieldBench (genRange @U2GenericStripPrefix)
77+
, mkToFieldBench (genRange @U4)
78+
, mkToFieldBench (genRange @U4Generic)
79+
, mkToFieldBench (genRange @U4GenericStripPrefix)
80+
, mkToFieldBench (genRange @U8)
81+
, mkToFieldBench (genRange @U8Generic)
82+
, mkToFieldBench (genRange @U8GenericStripPrefix)
83+
, mkToFieldBench (genRange @U16)
84+
, mkToFieldBench (genRange @U16Generic)
85+
, mkToFieldBench (genRange @U16GenericStripPrefix)
86+
, mkToFieldBench (genRange @U32)
87+
, mkToFieldBench (genRange @U32Generic)
88+
, mkToFieldBench (genRange @U32GenericStripPrefix)
89+
, mkToFieldBench manualEither0
90+
, mkToFieldBench genericEither0
91+
, mkToFieldBench manualEither1
92+
, mkToFieldBench genericEither1
93+
, mkToFieldBench manualEither2
94+
, mkToFieldBench genericEither2
95+
, mkToFieldBench manualEither3
96+
, mkToFieldBench genericEither3
4297
]
4398
]
4499

45-
type IsBench a = (Bounded a, Enum a, FromField a, ToField a, NFData a)
46-
47-
mkParseSuccessBench
48-
:: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix)
49-
=> Proxy a
50-
-> Proxy generic
51-
-> Proxy genericWithPrefix
52-
-> Benchmark
53-
mkParseSuccessBench px pxGen pxGenPfx = bgroup (show $ typeRep px)
54-
[ mkB "manual" px
55-
, mkB "generic" pxGen
56-
, mkB "generic with prefix" pxGenPfx
57-
]
58-
where
59-
{-
60-
NB: this all is about sum representations.
61-
Manual instance tries to parse constructors from left to right,
62-
so parsing the string matching the first constructor is the best case,
63-
while parsing the last matcher is the worst case.
64-
Generic representation is, however, not that flat (one can check that by
65-
exploring 'Rep' of U32) and is more like a balanced binary tree with root
66-
being somewhere around U32_16 constructor (rough estimation).
67-
To level this discrepency and compare parsing efficiency more accurately
68-
we parse the whole range @[minBound..maxBound]@ of possible values for a type.
69-
This corresponds to the situation where data values are uniformly distributed.
70-
-}
71-
mkB
72-
:: (Bounded a, Enum a, FromField a, ToField a, NFData a)
73-
=> String -> Proxy a -> Benchmark
74-
mkB name p = env (pure $ map toField $ genEnum p) $ bench name . nf (go p)
75-
go :: (FromField a) => Proxy a -> [Field] -> [a]
76-
go p = map $ ((\(Right x) -> x `asProxyTypeOf` p) . parse)
77-
78-
mkParseFailBench
79-
:: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix)
80-
=> Proxy a
81-
-> Proxy generic
82-
-> Proxy genericWithPrefix
83-
-> Benchmark
84-
mkParseFailBench px pxg pxgp = bgroup (show $ typeRep px)
85-
[ bench "manual" $ whnf (\s -> parse s `asProxyEither` px) mempty
86-
, bench "generic" $ whnf (\s -> parse s `asProxyEither` pxg) mempty
87-
, bench "generic with prefix" $ whnf (\s -> parse s `asProxyEither` pxgp) mempty
88-
]
100+
type IsBench a = (FromField a, ToField a, NFData a, Typeable a)
89101

90-
asProxyEither :: Either String a -> Proxy a -> Either String a
91-
asProxyEither = const
92-
93-
mkToFieldBench
94-
:: (IsBench a, Typeable a, IsBench generic, IsBench genericWithPrefix)
95-
=> Proxy a
96-
-> Proxy generic
97-
-> Proxy genericWithPrefix
98-
-> Benchmark
99-
mkToFieldBench px pxg pxgp = bgroup (show $ typeRep px)
100-
[ mkB "manual" px
101-
, mkB "generic" pxg
102-
, mkB "generic with prefix" pxgp
103-
]
102+
{-
103+
Manual instance tries to parse constructors from left to right,
104+
so parsing the string matching the first constructor is the best case,
105+
while parsing the last matcher is the worst case.
106+
Generic representation is, however, not that flat (one can check that by
107+
exploring 'Rep' of U32) and is more like a balanced binary tree with root
108+
being somewhere around U32_16 constructor (rough estimation).
109+
To level this discrepency and compare parsing efficiency more accurately
110+
we parse some range (@[minBound..maxBound]@ for enum) of possible values for a type.
111+
This corresponds to the situation where data values are uniformly distributed.
112+
-}
113+
mkParseSuccessBench :: (IsBench a) => [a] -> Benchmark
114+
mkParseSuccessBench xs = env (pure $ map toField xs) $
115+
bench (show $ typeRep xs) . nf (map $ (\(Right x) -> x `asProxyTypeOf` xs) . parse)
116+
117+
mkParseFailBench :: (IsBench a) => Proxy a -> Benchmark
118+
mkParseFailBench px = bench (show $ typeRep px) $
119+
nf (\s -> parse s `asProxyEither` px) mempty
104120
where
105-
mkB :: (Bounded a, Enum a, ToField a) => String -> Proxy a -> Benchmark
106-
mkB name = bench name . nf (map toField) . genEnum
121+
asProxyEither :: Either String a -> Proxy a -> Either String a
122+
asProxyEither x _ = x
123+
124+
mkToFieldBench :: (IsBench a) => [a] -> Benchmark
125+
mkToFieldBench xs = env (pure xs) $ bench (show $ typeRep xs) . nf (map toField)
107126

108127
parse :: (FromField a) => Field -> Either String a
109128
parse = runParser . parseField
110129

111-
genEnum :: (Bounded a, Enum a) => Proxy a -> [a]
112-
genEnum _ = [minBound..maxBound]
130+
genRange :: (Bounded a, Enum a) => [a]
131+
genRange = take 32 $ cycle [minBound..maxBound]
132+
133+
manualEither0 :: [ManualEither0]
134+
manualEither0 = take 32 $ cycle
135+
[ LManual 1
136+
, RManual '!'
137+
]
138+
139+
genericEither0 :: [GenericEither0]
140+
genericEither0 = take 32 $ cycle
141+
[ LGeneric 1
142+
, RGeneric '!'
143+
]
144+
145+
manualEither1 :: [ManualEither1]
146+
manualEither1 = take 32 $ cycle
147+
[ LManual $ LManual 1
148+
, LManual $ RManual '!'
149+
, RManual $ LManual 1
150+
, RManual $ RManual '!'
151+
]
152+
153+
genericEither1 :: [GenericEither1]
154+
genericEither1 = take 32 $ cycle
155+
[ LGeneric $ LGeneric 1
156+
, LGeneric $ RGeneric '!'
157+
, RGeneric $ LGeneric 1
158+
, RGeneric $ RGeneric '!'
159+
]
160+
161+
manualEither2 :: [ManualEither2]
162+
manualEither2 = take 32 $ cycle
163+
[ LManual $ LManual $ LManual 1
164+
, LManual $ LManual $ RManual '!'
165+
, LManual $ RManual $ LManual 1
166+
, LManual $ RManual $ RManual '!'
167+
, RManual $ LManual $ LManual 1
168+
, RManual $ LManual $ RManual '!'
169+
, RManual $ RManual $ LManual 1
170+
, RManual $ RManual $ RManual '!'
171+
]
172+
173+
genericEither2 :: [GenericEither2]
174+
genericEither2 = take 32 $ cycle
175+
[ LGeneric $ LGeneric $ LGeneric 1
176+
, LGeneric $ LGeneric $ RGeneric '!'
177+
, LGeneric $ RGeneric $ LGeneric 1
178+
, LGeneric $ RGeneric $ RGeneric '!'
179+
, RGeneric $ LGeneric $ LGeneric 1
180+
, RGeneric $ LGeneric $ RGeneric '!'
181+
, RGeneric $ RGeneric $ LGeneric 1
182+
, RGeneric $ RGeneric $ RGeneric '!'
183+
]
184+
185+
manualEither3 :: [ManualEither3]
186+
manualEither3 = take 32 $ cycle
187+
[ LManual $ LManual $ LManual $ LManual 1
188+
, LManual $ LManual $ LManual $ RManual '!'
189+
, LManual $ LManual $ RManual $ LManual 1
190+
, LManual $ LManual $ RManual $ RManual '!'
191+
, LManual $ RManual $ LManual $ LManual 1
192+
, LManual $ RManual $ LManual $ RManual '!'
193+
, LManual $ RManual $ RManual $ LManual 1
194+
, LManual $ RManual $ RManual $ RManual '!'
195+
, RManual $ LManual $ LManual $ LManual 1
196+
, RManual $ LManual $ LManual $ RManual '!'
197+
, RManual $ LManual $ RManual $ LManual 1
198+
, RManual $ LManual $ RManual $ RManual '!'
199+
, RManual $ RManual $ LManual $ LManual 1
200+
, RManual $ RManual $ LManual $ RManual '!'
201+
, RManual $ RManual $ RManual $ LManual 1
202+
, RManual $ RManual $ RManual $ RManual '!'
203+
]
204+
205+
genericEither3 :: [GenericEither3]
206+
genericEither3 = take 32 $ cycle
207+
[ LGeneric $ LGeneric $ LGeneric $ LGeneric 1
208+
, LGeneric $ LGeneric $ LGeneric $ RGeneric '!'
209+
, LGeneric $ LGeneric $ RGeneric $ LGeneric 1
210+
, LGeneric $ LGeneric $ RGeneric $ RGeneric '!'
211+
, LGeneric $ RGeneric $ LGeneric $ LGeneric 1
212+
, LGeneric $ RGeneric $ LGeneric $ RGeneric '!'
213+
, LGeneric $ RGeneric $ RGeneric $ LGeneric 1
214+
, LGeneric $ RGeneric $ RGeneric $ RGeneric '!'
215+
, RGeneric $ LGeneric $ LGeneric $ LGeneric 1
216+
, RGeneric $ LGeneric $ LGeneric $ RGeneric '!'
217+
, RGeneric $ LGeneric $ RGeneric $ LGeneric 1
218+
, RGeneric $ LGeneric $ RGeneric $ RGeneric '!'
219+
, RGeneric $ RGeneric $ LGeneric $ LGeneric 1
220+
, RGeneric $ RGeneric $ LGeneric $ RGeneric '!'
221+
, RGeneric $ RGeneric $ RGeneric $ LGeneric 1
222+
, RGeneric $ RGeneric $ RGeneric $ RGeneric '!'
223+
]

‎benchmarks/cassava-iut.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,8 @@ Benchmark benchmark-iut
101101
Type: exitcode-stdio-1.0
102102
Main-is: Benchmarks.hs
103103
other-modules: GenericFieldBench
104+
Generic.Either
105+
Generic.Prefix
104106
Generic.U2
105107
Generic.U4
106108
Generic.U8
@@ -128,6 +130,8 @@ Benchmark benchmark-ref
128130
Type: exitcode-stdio-1.0
129131
Main-is: Benchmarks.hs
130132
other-modules: GenericFieldBench
133+
Generic.Either
134+
Generic.Prefix
131135
Generic.U2
132136
Generic.U4
133137
Generic.U8

0 commit comments

Comments
 (0)