b32a660 · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

working generic breakdown

b32a660Mark Wotton6 years ago

roboservant.cabal+2−1

compare with master

unifiedsplit

@@ -4,7 +4,7 @@ cabal-version: 1.12

4--

5-- see: https://github.com/sol/hpack

6--

7−-- hash: 259bc9e689003f4c9cb6d24bb6e68043f20c1401cf4031df677aac6909983f33

7+-- hash: 3b8eaf26233853cd94e20de7f84c25d6124cd919072681c3287a761526f82b9e

9name: roboservant

10version: 0.1.0.2

@@ -66,6 +66,7 @@ test-suite roboservant-test

66 type: exitcode-stdio-1.0

67 main-is: Spec.hs

68 other-modules:

69+ Breakdown

69 Foo

70 Foo

70 Headers

71 Headers

71 Post

72 Post

src/Roboservant/Types/Breakdown.hs+38−32

@@ -1,59 +1,65 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DerivingVia #-}

4−{-# LANGUAGE DerivingVia #-}

5−

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE StandaloneDeriving #-}

8−

9−{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

11−

12{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

13−{-# LANGUAGE GADTs #-}

14−

15−{-# LANGUAGE DefaultSignatures #-}

16−{-# LANGUAGE DerivingStrategies #-}

17−{-# LANGUAGE FlexibleInstances #-}

18−{-# LANGUAGE GADTs #-}

19−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

20{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

21{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

22{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

23{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

24−{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE StandaloneDeriving #-}

25{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

26{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

27−{-# LANGUAGE StandaloneDeriving #-}

28−{-# LANGUAGE DerivingVia #-}

29−

31module Roboservant.Types.Breakdown where

15module Roboservant.Types.Breakdown where

33−import Data.Dynamic (Dynamic, fromDynamic, toDyn)

17+import Data.Dynamic (Dynamic, toDyn)

34import Data.List.NonEmpty (NonEmpty (..))

18import Data.List.NonEmpty (NonEmpty (..))

35−import qualified Data.List.NonEmpty as NEL

36−import Data.Maybe (fromMaybe)

37−import GHC.Generics(Generic)

19+import GHC.Generics

38import Data.Typeable (Typeable)

20import Data.Typeable (Typeable)

39import Roboservant.Types.Internal

21import Roboservant.Types.Internal

40import Data.Hashable

22import Data.Hashable

23+import Data.Kind

24+import qualified Data.List.NonEmpty as NEL

42−-- | only use this when we are using the internal typerep map.

26+breakdown :: (Hashable x, Typeable x, Breakdown x)

43−promisedDyn :: Typeable a => Dynamic -> a

27+ => x -> NonEmpty (Dynamic, Int)

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

28+breakdown x = hashedDyn x :| breakdownExtras x

46class Breakdown x where

30class Breakdown x where

47− breakdown :: x -> NonEmpty (Dynamic,Int)

31+ breakdownExtras :: x -> [(Dynamic,Int)]

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

49−-- breakdown = pure . toDyn

50−

52instance (Hashable x, Typeable x) => Breakdown (Atom x) where

33instance (Hashable x, Typeable x) => Breakdown (Atom x) where

53− breakdown (Atom x) = pure (toDyn x, hash x)

34+ breakdownExtras (Atom x) = [(toDyn x, hash x)]

55deriving via (Atom ()) instance Breakdown ()

36deriving via (Atom ()) instance Breakdown ()

56deriving via (Atom Int) instance Breakdown Int

37deriving via (Atom Int) instance Breakdown Int

38+deriving via (Atom [Char]) instance Breakdown [Char]

39+

40+class GBreakdown (f :: k -> *) where

41+ gBreakdownExtras :: f a -> [(Dynamic,Int)]

42+

43+instance (Hashable x, Typeable x, Generic x, GBreakdown (Rep x)) => Breakdown (Compound (x::Type)) where

44+ breakdownExtras = gBreakdownExtras . from . unCompound

45+

46+instance GBreakdown f => GBreakdown (M1 S c f ) where

47+ gBreakdownExtras (M1 f) = gBreakdownExtras f

48+

49+instance GBreakdown b => GBreakdown (M1 D a b) where

50+ gBreakdownExtras (M1 f) = gBreakdownExtras f

51+

52+

53+instance GBreakdown b => GBreakdown (M1 C a b) where

54+ gBreakdownExtras (M1 f) = gBreakdownExtras f

55+

56+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :*: b) where

57+ gBreakdownExtras (a :*: b) = gBreakdownExtras a <> gBreakdownExtras b

58+

59+instance (GBreakdown a, GBreakdown b) => GBreakdown (a :+: b) where

60+ gBreakdownExtras = \case

61+ L1 a -> gBreakdownExtras a

62+ R1 a -> gBreakdownExtras a

58−-- instance (Typeable a, Breakdown a) => Breakdown [a] where

64+instance (Hashable a, Typeable a, Breakdown a) => GBreakdown (K1 R a) where

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

65+ gBreakdownExtras (K1 c) = NEL.toList $ breakdown c

src/Roboservant/Types/Internal.hs+5−1

@@ -12,9 +12,10 @@ import Data.Dependent.Map (DMap)

12import qualified Type.Reflection as R

13import Data.Dependent.Sum

14import Data.IntSet(IntSet)

15−import Data.Hashable(Hashable)

15+import Data.Hashable(Hashable,hash)

16import GHC.Generics(Generic)

17import Data.Typeable(Typeable)

18+import Data.Dynamic(Dynamic,toDyn)

19data Provenance

20data Provenance

20 = Provenance R.SomeTypeRep Int

21 = Provenance R.SomeTypeRep Int

@@ -43,3 +44,6 @@ newtype Atom x = Atom { unAtom :: x }

43-- | can be broken down and built up from generic pieces

44-- | can be broken down and built up from generic pieces

44newtype Compound x = Compound { unCompound :: x }

45newtype Compound x = Compound { unCompound :: x }

45 deriving newtype (Hashable,Typeable)

46 deriving newtype (Hashable,Typeable)

47+

48+hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)

49+hashedDyn a = (toDyn a, hash a)

src/Roboservant/Types/ReifiedApi.hs+2−2

@@ -38,7 +38,7 @@ import qualified Data.Text as T

38import qualified Data.Vinyl as V

39import qualified Data.Vinyl.Curry as V

40import qualified Type.Reflection as R

41−

41+import Data.Hashable(Hashable)

43newtype ApiOffset = ApiOffset Int

44 deriving (Eq, Show, Ord)

@@ -101,7 +101,7 @@ instance NormalizeFunction x => NormalizeFunction (r -> x) where

101 type Normal (r -> x) = r -> Normal x

102 normalize = fmap normalize

103

104−instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where

104+instance (Typeable x, Hashable x, Breakdown x) => NormalizeFunction (Handler x) where

105 type Normal (Handler x) = IO (Either ServerError (NonEmpty (Dynamic,Int)))

106 normalize handler = (runExceptT . runHandler') handler >>= \case

107 Left serverError -> pure (Left serverError)

test/Breakdown.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingStrategies #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE TypeOperators #-}

8+module Breakdown where

10+import Data.Aeson

11+import Data.Typeable (Typeable)

12+import GHC.Generics (Generic)

13+import Servant

14+import Data.Hashable

15+

16+data Foo = Foo Int String

17+ deriving (Generic, Eq, Show, Typeable)

18+

19+instance Hashable Foo

20+instance ToJSON Foo

21+instance FromJSON Foo

22+

23+

24+data SomeSum = A Int | B String

25+ deriving (Generic, Eq, Show, Typeable)

26+

27+instance Hashable SomeSum

28+instance ToJSON SomeSum

29+instance FromJSON SomeSum

30+

31+

32+type ProductApi = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

33+ :<|> "getFoo" :> Get '[JSON] Foo

34+

35+eliminate :: Int -> Handler ()

36+eliminate _ = throwError $ err500 {errBody = "eliminate blew up, oh no!"}

37+

38+productServer :: Server ProductApi

39+productServer = eliminate :<|> pure (Foo 12 "abc")

40+

41+

42+type SumApi

43+ = "item" :> ReqBody '[JSON] Int :> Post '[JSON] ()

44+ :<|> "getFoo1" :> Get '[JSON] SomeSum

45+ :<|> "getFoo2" :> Get '[JSON] SomeSum

46+

47+

48+

49+sumServer :: Server SumApi

50+sumServer = eliminate :<|> pure (B "hi") :<|> pure (A 3)

test/Spec.hs+15−4

@@ -13,6 +13,7 @@ import qualified Valid

13import qualified Headers

14import qualified Post

15import qualified Product

16+import qualified Breakdown

17import Test.Hspec.Core.Spec

18import Test.Hspec.Core.Spec

@@ -72,6 +73,7 @@ spec = do

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

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

73 >>= (`shouldSatisfy` serverFailure)

74 >>= (`shouldSatisfy` serverFailure)

76+ describe "BuildFrom" $ do

75 describe "headers (and sum types)" $ do

77 describe "headers (and sum types)" $ do

76 it "should find a failure that's dependent on using header info" $ do

78 it "should find a failure that's dependent on using header info" $ do

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

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

@@ -79,12 +81,18 @@ spec = do

80 describe "product types" $ do

82 describe "product types" $ do

81 it "should find a failure that's dependent on creating a product" $ do

83 it "should find a failure that's dependent on creating a product" $ do

82− RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [hashedDyn 'a', hashedDyn (1::Int)]} noCheck

84+ RS.fuzz @Product.Api Product.server defaultConfig { RS.seed = [RS.hashedDyn 'a', RS.hashedDyn (1::Int)]} noCheck

83 >>= (`shouldSatisfy` serverFailure)

85 >>= (`shouldSatisfy` serverFailure)

84− -- >>= (`shouldSatisfy` isJust)

86−hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)

87+ describe "Breakdown" $ do

87−hashedDyn a = (toDyn a, hash a)

88+ it "handles products" $ do

89+ RS.fuzz @Breakdown.ProductApi Breakdown.productServer defaultConfig noCheck

90+ >>= (`shouldSatisfy` serverFailure)

91+

92+ it "handles sums" $ do

93+ RS.fuzz @Breakdown.SumApi Breakdown.sumServer defaultConfig noCheck

94+ >>= (`shouldSatisfy` serverFailure)

95+

89serverFailure :: Maybe RS.Report -> Bool

97serverFailure :: Maybe RS.Report -> Bool

90serverFailure = \case

98serverFailure = \case

@@ -133,6 +141,9 @@ deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost

133deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost

141deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost

134

142

135deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo

143deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo

144+deriving via (RS.Compound Breakdown.Foo) instance RS.Breakdown Breakdown.Foo

145+deriving via (RS.Compound Breakdown.SomeSum) instance RS.Breakdown Breakdown.SomeSum

146+

136

147

137

148

138--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped

149--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped