2498df9 · roboservant · git.iko.soy

git.iko.soy/roboservant

switch to deriving-via rather than default

commit2498df9cd0457e33a9d02f8d06605ace786e4178 authorMark Wotton <mwotton@gmail.com> dateSun 22 Nov 2020, 10:01 (6 years ago) parentcaa02ac

2 files changed+47−38

compare with master

unifiedsplit

src/Roboservant/Types/Breakdown.hs+23−20 test/Spec.hs+24−18

src/Roboservant/Types/Breakdown.hs+23−20

@@ -1,18 +1,15 @@

11{-# LANGUAGE AllowAmbiguousTypes #-}

22{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DerivingVia #-}

4+{-# LANGUAGE StandaloneDeriving #-}

35{-# LANGUAGE DefaultSignatures #-}

46{-# LANGUAGE DerivingStrategies #-}

57{-# LANGUAGE FlexibleInstances #-}

68{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE LambdaCase #-}

99{-# LANGUAGE PolyKinds #-}

1010{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE StandaloneDeriving #-}

12−{-# LANGUAGE TupleSections #-}

1311{-# LANGUAGE TypeApplications #-}

1412{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeOperators #-}

1613{-# LANGUAGE UndecidableInstances #-}

1714

1815module Roboservant.Types.Breakdown where

@@ -33,9 +30,17 @@ type Stash = Map TypeRep (NonEmpty ([Provenance], Dynamic))

3330

3431class Typeable x => BuildFrom x where

3532 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

3741 buildFrom = Map.lookup (typeRep (Proxy @x))

3842

43+

3944 -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))

4045

4146

@@ -47,7 +52,8 @@ class Typeable x => BuildFrom x where

4752promisedDyn :: Typeable a => Dynamic -> a

4853promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic

4954

50−instance BuildFrom Bool

55+-- instance BuildFrom Bool

56+deriving via (Atomic Bool) instance BuildFrom Bool

5157

5258instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

5359 buildFrom dict = Just $ fmap toDyn <$> options

@@ -58,22 +64,19 @@ instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

5864

5965class Breakdown x where

6066 breakdown :: x -> NonEmpty Dynamic

61− default breakdown :: Typeable x => x -> NonEmpty Dynamic

62− breakdown = pure . toDyn

63−

67+-- default breakdown :: Typeable x => x -> NonEmpty Dynamic

68+-- breakdown = pure . toDyn

69+

6470-- | Can't break it down any further -- stuck in your teeth, maybe.

6571newtype Chewy x = Chewy { unChew :: x }

6672

67−instance Breakdown () where

68− breakdown = pure . toDyn

73+instance Typeable a => Breakdown (Chewy a) where

74+ breakdown = pure . toDyn . unChew

6975

70−instance Breakdown Int where

71− breakdown = pure . toDyn

76+deriving via (Chewy ()) instance Breakdown ()

77+deriving via (Chewy Int) instance Breakdown Int

7278

7379

74−instance Typeable x => Breakdown (Chewy x) where

75− breakdown x = pure (toDyn x)

76−

7780--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]

7881

7982-- instance (Typeable x, Generic x) => Breakdown x where

@@ -83,6 +86,6 @@ instance Typeable x => Breakdown (Chewy x) where

8386instance (Typeable a, Breakdown a) => Breakdown [a] where

8487 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

8588

86−instance (BuildFrom a) => BuildFrom [a] -- where

87−-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

88−

89+instance (BuildFrom a) => BuildFrom [a] where

90+ buildFrom = error "fuuuck"

91+--- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)

test/Spec.hs+24−18

@@ -1,5 +1,7 @@

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE StandaloneDeriving #-}

4+{-# LANGUAGE DerivingVia #-}

35{-# LANGUAGE TypeApplications #-}

46{-# LANGUAGE LambdaCase #-}

57{-# OPTIONS_GHC -fno-warn-orphans #-}

@@ -12,7 +14,7 @@ import qualified Post

1214

1315import Data.Dynamic(toDyn)

1416import qualified Roboservant as RS

15−

17+import Roboservant(Chewy,Breakdown, BuildFrom, Atomic)

1618import Test.Hspec

1719import Test.Hspec.Core.Spec

1820import Data.Void

@@ -44,22 +46,22 @@ spec = do

4446 describe "posted body" $ do

4547 it "passes a coverage check using a posted body" $ do

4648 RS.fuzz @Post.Api Post.server defaultConfig { RS.coverageThreshold = 0.99 } noCheck

47− >>= (`shouldSatisfy` isNothing)

48−

49+ >>= (`shouldSatisfy` isNothing)

50+

4951 describe "seeded" $ do

5052 shouldFail $

5153 it "finds an error using information passed in" $

5254 RS.fuzz @Seeded.Api Seeded.server (defaultConfig{ RS.seed = [toDyn $ Seeded.Seed 1] }) noCheck

5355 >>= (`shouldSatisfy` isNothing)

54− describe "Foo" $ do

55− shouldFail $ it "finds an error in a basic app" $

56+ describe "Foo" $ do

57+ it "finds an error in a basic app" $

5658 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck

57− >>= (`shouldSatisfy` isNothing)

59+ >>= (`shouldSatisfy` isJust)

5860

5961 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

6163 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck

62− >>= (`shouldSatisfy` isNothing)

64+ >>= (`shouldSatisfy` isJust)

6365

6466 -- -- -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it

6567 -- -- -- could: it's mostly here to show how to test for concurrency problems.

@@ -76,23 +78,27 @@ spec = do

7678 -- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []

7779

7880

79−instance RS.Breakdown Foo.Foo where

80− breakdown = pure . toDyn

81+deriving via (Chewy Foo.Foo) instance Breakdown Foo.Foo

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

8186

87+deriving via (Chewy Seeded.Seed) instance Breakdown Seeded.Seed

88+deriving via (Atomic Seeded.Seed) instance BuildFrom Seeded.Seed

8289

83−instance RS.Breakdown Headers.Foo where

84− breakdown = pure . toDyn

8590

86−instance RS.BuildFrom Foo.Foo

91+-- instance RS.BuildFrom Seeded.Seed

8792

88−instance RS.BuildFrom Headers.Foo

93+deriving via (Atomic Void) instance RS.BuildFrom Void

8994

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

9197

92−instance RS.BuildFrom Void

98+-- deriving via (Atomic Void) instance RS.BuildFrom Void

9399

94−instance RS.Breakdown Post.FooPost

95−instance RS.BuildFrom Post.FooPost

100+-- instance RS.Breakdown Post.FooPost

101+-- instance RS.BuildFrom Post.FooPost

96102

97103

98104-- | `shouldFail` allows you to assert that a given `Spec` should contain at least one failing test.