Skip to content

Commit 2721f0d

Browse files
stevladimirstevladimir
committed
Add tests for Either
1 parent b5575b0 commit 2721f0d

File tree

3 files changed

+238
-78
lines changed

3 files changed

+238
-78
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: 161 additions & 78 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,176 @@ 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 $ take 32 $ cycle @ManualEither0
40+
[ LManual 1
41+
, RManual '!'
42+
]
43+
, mkParseSuccessBench $ take 32 $ cycle @GenericEither0
44+
[ LGeneric 1
45+
, RGeneric '!'
46+
]
47+
, mkParseSuccessBench $ take 32 $ cycle @ManualEither1
48+
[ LManual $ LManual 1
49+
, LManual $ RManual '!'
50+
, RManual $ LManual 1
51+
, RManual $ RManual '!'
52+
]
53+
, mkParseSuccessBench $ take 32 $ cycle @GenericEither1
54+
[ LGeneric $ LGeneric 1
55+
, LGeneric $ RGeneric '!'
56+
, RGeneric $ LGeneric 1
57+
, RGeneric $ RGeneric '!'
58+
]
59+
, mkParseSuccessBench $ take 32 $ cycle @ManualEither2
60+
[ LManual $ LManual $ LManual 1
61+
, LManual $ LManual $ RManual '!'
62+
, LManual $ RManual $ LManual 1
63+
, LManual $ RManual $ RManual '!'
64+
, RManual $ LManual $ LManual 1
65+
, RManual $ LManual $ RManual '!'
66+
, RManual $ RManual $ LManual 1
67+
, RManual $ RManual $ RManual '!'
68+
]
69+
, mkParseSuccessBench $ take 32 $ cycle @GenericEither2
70+
[ LGeneric $ LGeneric $ LGeneric 1
71+
, LGeneric $ LGeneric $ RGeneric '!'
72+
, LGeneric $ RGeneric $ LGeneric 1
73+
, LGeneric $ RGeneric $ RGeneric '!'
74+
, RGeneric $ LGeneric $ LGeneric 1
75+
, RGeneric $ LGeneric $ RGeneric '!'
76+
, RGeneric $ RGeneric $ LGeneric 1
77+
, RGeneric $ RGeneric $ RGeneric '!'
78+
]
79+
, mkParseSuccessBench $ take 32 $ cycle @ManualEither3
80+
[ LManual $ LManual $ LManual $ LManual 1
81+
, LManual $ LManual $ LManual $ RManual '!'
82+
, LManual $ LManual $ RManual $ LManual 1
83+
, LManual $ LManual $ RManual $ RManual '!'
84+
, LManual $ RManual $ LManual $ LManual 1
85+
, LManual $ RManual $ LManual $ RManual '!'
86+
, LManual $ RManual $ RManual $ LManual 1
87+
, LManual $ RManual $ RManual $ RManual '!'
88+
, RManual $ LManual $ LManual $ LManual 1
89+
, RManual $ LManual $ LManual $ RManual '!'
90+
, RManual $ LManual $ RManual $ LManual 1
91+
, RManual $ LManual $ RManual $ RManual '!'
92+
, RManual $ RManual $ LManual $ LManual 1
93+
, RManual $ RManual $ LManual $ RManual '!'
94+
, RManual $ RManual $ RManual $ LManual 1
95+
, RManual $ RManual $ RManual $ RManual '!'
96+
]
97+
, mkParseSuccessBench $ take 32 $ cycle @GenericEither3
98+
[ LGeneric $ LGeneric $ LGeneric $ LGeneric 1
99+
, LGeneric $ LGeneric $ LGeneric $ RGeneric '!'
100+
, LGeneric $ LGeneric $ RGeneric $ LGeneric 1
101+
, LGeneric $ LGeneric $ RGeneric $ RGeneric '!'
102+
, LGeneric $ RGeneric $ LGeneric $ LGeneric 1
103+
, LGeneric $ RGeneric $ LGeneric $ RGeneric '!'
104+
, LGeneric $ RGeneric $ RGeneric $ LGeneric 1
105+
, LGeneric $ RGeneric $ RGeneric $ RGeneric '!'
106+
, RGeneric $ LGeneric $ LGeneric $ LGeneric 1
107+
, RGeneric $ LGeneric $ LGeneric $ RGeneric '!'
108+
, RGeneric $ LGeneric $ RGeneric $ LGeneric 1
109+
, RGeneric $ LGeneric $ RGeneric $ RGeneric '!'
110+
, RGeneric $ RGeneric $ LGeneric $ LGeneric 1
111+
, RGeneric $ RGeneric $ LGeneric $ RGeneric '!'
112+
, RGeneric $ RGeneric $ RGeneric $ LGeneric 1
113+
, RGeneric $ RGeneric $ RGeneric $ RGeneric '!'
114+
]
28115
]
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)
116+
, bgroup "parseField:fail"
117+
[ mkParseFailBench (Proxy @U2)
118+
, mkParseFailBench (Proxy @U2Generic)
119+
, mkParseFailBench (Proxy @U2GenericStripPrefix)
120+
, mkParseFailBench (Proxy @U4)
121+
, mkParseFailBench (Proxy @U4Generic)
122+
, mkParseFailBench (Proxy @U4GenericStripPrefix)
123+
, mkParseFailBench (Proxy @U8)
124+
, mkParseFailBench (Proxy @U8Generic)
125+
, mkParseFailBench (Proxy @U8GenericStripPrefix)
126+
, mkParseFailBench (Proxy @U16)
127+
, mkParseFailBench (Proxy @U16Generic)
128+
, mkParseFailBench (Proxy @U16GenericStripPrefix)
129+
, mkParseFailBench (Proxy @U32)
130+
, mkParseFailBench (Proxy @U32Generic)
131+
, mkParseFailBench (Proxy @U32GenericStripPrefix)
132+
, mkParseFailBench (Proxy @ManualEither0)
133+
, mkParseFailBench (Proxy @ManualEither1)
134+
, mkParseFailBench (Proxy @ManualEither2)
135+
, mkParseFailBench (Proxy @ManualEither3)
35136
]
36137
, 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)
138+
[ mkToFieldBench (genRange @U2)
139+
, mkToFieldBench (genRange @U2Generic)
140+
, mkToFieldBench (genRange @U2GenericStripPrefix)
141+
, mkToFieldBench (genRange @U4)
142+
, mkToFieldBench (genRange @U4Generic)
143+
, mkToFieldBench (genRange @U4GenericStripPrefix)
144+
, mkToFieldBench (genRange @U8)
145+
, mkToFieldBench (genRange @U8Generic)
146+
, mkToFieldBench (genRange @U8GenericStripPrefix)
147+
, mkToFieldBench (genRange @U16)
148+
, mkToFieldBench (genRange @U16Generic)
149+
, mkToFieldBench (genRange @U16GenericStripPrefix)
150+
, mkToFieldBench (genRange @U32)
151+
, mkToFieldBench (genRange @U32Generic)
152+
, mkToFieldBench (genRange @U32GenericStripPrefix)
42153
]
43154
]
44155

45-
type IsBench a = (Bounded a, Enum a, FromField a, ToField a, NFData a)
156+
type IsBench a = (FromField a, ToField a, NFData a, Typeable a)
46157

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-
]
89-
90-
asProxyEither :: Either String a -> Proxy a -> Either String a
91-
asProxyEither = const
158+
{-
159+
Manual instance tries to parse constructors from left to right,
160+
so parsing the string matching the first constructor is the best case,
161+
while parsing the last matcher is the worst case.
162+
Generic representation is, however, not that flat (one can check that by
163+
exploring 'Rep' of U32) and is more like a balanced binary tree with root
164+
being somewhere around U32_16 constructor (rough estimation).
165+
To level this discrepency and compare parsing efficiency more accurately
166+
we parse some range (@[minBound..maxBound]@ for enum) of possible values for a type.
167+
This corresponds to the situation where data values are uniformly distributed.
168+
-}
169+
mkParseSuccessBench :: (IsBench a) => [a] -> Benchmark
170+
mkParseSuccessBench xs = env (pure $ map toField xs) $
171+
bench (show $ typeRep xs) . nf (map $ (\(Right x) -> x `asProxyTypeOf` xs) . parse)
92172

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-
]
173+
mkParseFailBench :: (IsBench a) => Proxy a -> Benchmark
174+
mkParseFailBench px = bench (show $ typeRep px) $
175+
nf (\s -> parse s `asProxyEither` px) mempty
104176
where
105-
mkB :: (Bounded a, Enum a, ToField a) => String -> Proxy a -> Benchmark
106-
mkB name = bench name . nf (map toField) . genEnum
177+
asProxyEither :: Either String a -> Proxy a -> Either String a
178+
asProxyEither x _ = x
179+
180+
mkToFieldBench :: (IsBench a) => [a] -> Benchmark
181+
mkToFieldBench xs = env (pure xs) $ bench (show $ typeRep xs) . nf (map toField)
107182

108183
parse :: (FromField a) => Field -> Either String a
109184
parse = runParser . parseField
110185

111-
genEnum :: (Bounded a, Enum a) => Proxy a -> [a]
112-
genEnum _ = [minBound..maxBound]
186+
genRange :: (Bounded a, Enum a) => [a]
187+
genRange = take 32 $ cycle [minBound..maxBound]
188+
189+
-- manualEither0 :: (Int -> a) -> (Char -> a) -> [a]
190+
-- either0 f g = [f 1, g '!']
191+
192+
-- either1 :: (a -> b) -> (a -> b) -> [a]
193+
-- either1 f g = do
194+
-- x <- either0 f g
195+
-- [f x, g x]

‎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)