git.iko.soy/roboservant
on master help sign in
switch to deriving-via rather than default
2498df9Mark Wotton
src/Roboservant/Types/Breakdown.hs+23−20
compare with master
unifiedsplit
@@ -1,18 +1,15 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DerivingVia #-}
4+{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE DefaultSignatures #-}
5{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DerivingStrategies #-}
6{-# LANGUAGE DerivingStrategies #-}
5{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8−{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
12−{-# LANGUAGE TupleSections #-}
13{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeApplications #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
17
14
18module Roboservant.Types.Breakdown where
15module Roboservant.Types.Breakdown where
@@ -33,9 +30,17 @@ type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))
33
30
34class Typeable x => BuildFrom x where
31class Typeable x => BuildFrom x where
35 buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))
32 buildFrom :: Stash -> Maybe (NonEmpty ([Provenance],Dynamic))
36− default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
33+-- default buildFrom :: Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
34+-- buildFrom = Map.lookup (typeRep (Proxy @x))
35+
36+
37+-- | Can't be built up from parts
38+newtype Atomic x = Atomic x
39+
40+instance Typeable x => BuildFrom (Atomic x) where
37 buildFrom = Map.lookup (typeRep (Proxy @x))
41 buildFrom = Map.lookup (typeRep (Proxy @x))
38
42
43+
39 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
44 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
40
45
41
46
@@ -47,7 +52,8 @@ class Typeable x => BuildFrom x where
47promisedDyn :: Typeable a => Dynamic -> a
52promisedDyn :: Typeable a => Dynamic -> a
48promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
53promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
49
54
55+-- instance BuildFrom Bool
50−instance BuildFrom Bool
56+deriving via (Atomic Bool) instance BuildFrom Bool
51
57
52instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
58instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
53 buildFrom dict = Just $ fmap toDyn <$> options
59 buildFrom dict = Just $ fmap toDyn <$> options
@@ -58,22 +64,19 @@ instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
58
64
59class Breakdown x where
65class Breakdown x where
60 breakdown :: x -> NonEmpty Dynamic
66 breakdown :: x -> NonEmpty Dynamic
61− default breakdown :: Typeable x => x -> NonEmpty Dynamic
67+-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
62− breakdown = pure . toDyn
68+-- breakdown = pure . toDyn
63−
69+
64-- | Can't break it down any further -- stuck in your teeth, maybe.
70-- | Can't break it down any further -- stuck in your teeth, maybe.
65newtype Chewy x = Chewy { unChew :: x }
71newtype Chewy x = Chewy { unChew :: x }
66
72
67−instance Breakdown () where
73+instance Typeable a => Breakdown (Chewy a) where
68− breakdown = pure . toDyn
74+ breakdown = pure . toDyn . unChew
69
75
70−instance Breakdown Int where
76+deriving via (Chewy ()) instance Breakdown ()
71− breakdown = pure . toDyn
77+deriving via (Chewy Int) instance Breakdown Int
72
78
73
79
74−instance Typeable x => Breakdown (Chewy x) where
75− breakdown x = pure (toDyn x)
76−
77--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
80--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
78
81
79-- instance (Typeable x, Generic x) => Breakdown x where
82-- instance (Typeable x, Generic x) => Breakdown x where
@@ -83,6 +86,6 @@ instance Typeable x => Breakdown (Chewy x) where
83instance (Typeable a, Breakdown a) => Breakdown [a] where
86instance (Typeable a, Breakdown a) => Breakdown [a] where
84 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
87 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
85
88
86−instance (BuildFrom a) => BuildFrom [a] -- where
89+instance (BuildFrom a) => BuildFrom [a] where
90+ buildFrom = error "fuuuck"
87−-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
91+--- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
88−
test/Spec.hs+24−18
@@ -1,5 +1,7 @@
1
1
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE DerivingVia #-}
3{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeApplications #-}
4{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
7{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -12,7 +14,7 @@ import qualified Post
12
14
13import Data.Dynamic(toDyn)
15import Data.Dynamic(toDyn)
14import qualified Roboservant as RS
16import qualified Roboservant as RS
15−
17+import Roboservant(Chewy,Breakdown, BuildFrom, Atomic)
16import Test.Hspec
18import Test.Hspec
17import Test.Hspec.Core.Spec
19import Test.Hspec.Core.Spec
18import Data.Void
20import Data.Void
@@ -44,22 +46,22 @@ spec = do
44 describe "posted body" $ do
46 describe "posted body" $ do
45 it "passes a coverage check using a posted body" $ do
47 it "passes a coverage check using a posted body" $ do
46 RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
48 RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck
47− >>= (`shouldSatisfy` isNothing)
49+ >>= (`shouldSatisfy` isNothing)
48−
50+
49 describe "seeded" $ do
51 describe "seeded" $ do
50 shouldFail $
52 shouldFail $
51 it "finds an error using information passed in" $
53 it "finds an error using information passed in" $
52 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
54 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck
53 >>= (`shouldSatisfy` isNothing)
55 >>= (`shouldSatisfy` isNothing)
54− describe "Foo" $ do
56+ describe "Foo" $ do
55− shouldFail $ it "finds an error in a basic app" $
57+ it "finds an error in a basic app" $
56 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
58 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
57− >>= (`shouldSatisfy` isNothing)
59+ >>= (`shouldSatisfy` isJust)
58
60
59 describe "headers" $ do
61 describe "headers" $ do
60− shouldFail $ it "should find a failure that's dependent on using header info" $ do
62+ it "should find a failure that's dependent on using header info" $ do
61 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
63 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
62− >>= (`shouldSatisfy` isNothing)
64+ >>= (`shouldSatisfy` isJust)
63
65
64 -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
66 -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it
65 -- -- -- could: it's mostly here to show how to test for concurrency problems.
67 -- -- -- could: it's mostly here to show how to test for concurrency problems.
@@ -76,23 +78,27 @@ spec = do
76 -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
78 -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
77
79
78
80
79−instance RS.Breakdown Foo.Foo where
81+deriving via (Chewy Foo.Foo) instance Breakdown Foo.Foo
80− breakdown = pure . toDyn
82+deriving via (Atomic Foo.Foo) instance BuildFrom Foo.Foo
83+
84+deriving via (Chewy Headers.Foo) instance Breakdown Headers.Foo
85+deriving via (Atomic Headers.Foo) instance BuildFrom Headers.Foo
81
86
87+deriving via (Chewy Seeded.Seed) instance Breakdown Seeded.Seed
88+deriving via (Atomic Seeded.Seed) instance BuildFrom Seeded.Seed
82
89
83−instance RS.Breakdown Headers.Foo where
84− breakdown = pure . toDyn
85
90
86−instance RS.BuildFrom Foo.Foo
91+-- instance RS.BuildFrom Seeded.Seed
87
92
88−instance RS.BuildFrom Headers.Foo
93+deriving via (Atomic Void) instance RS.BuildFrom Void
89
94
90−instance RS.BuildFrom Seeded.Seed
95+deriving via (Atomic Post.FooPost) instance RS.BuildFrom Post.FooPost
96+deriving via (Chewy Post.FooPost) instance RS.Breakdown Post.FooPost
91
97
92−instance RS.BuildFrom Void
98+-- deriving via (Atomic Void) instance RS.BuildFrom Void
93
99
94−instance RS.Breakdown Post.FooPost
100+-- instance RS.Breakdown Post.FooPost
95−instance RS.BuildFrom Post.FooPost
101+-- instance RS.BuildFrom Post.FooPost
96
102
97
103
98-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.
104-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.