git.iko.soy/roboservant
on master help sign in
working products
commit9a40123f362c1b4674a19ef65eeda0f4b4468c7c authorMark Wotton <mwotton@gmail.com> dateMon 21 Dec 2020, 15:40 (6 years ago) parentb61d91d
4 files changed+74−12
compare with master
unifiedsplit
roboservant.cabal+2−3 src/Roboservant/Types/BuildFrom.hs+18 test/Product.hs+29 test/Spec.hs+25−9
roboservant.cabal+2−3
@@ -4,7 +4,7 @@ cabal-version: 1.12
44--
55-- see: https://github.com/sol/hpack
66--
7−-- hash: 2413ea31d818460d71253663fb2f666a183719df85b1ca874016de1d174a0a96
7+-- hash: 259bc9e689003f4c9cb6d24bb6e68043f20c1401cf4031df677aac6909983f33
88
99name: roboservant
1010version: 0.1.0.2
@@ -33,7 +33,6 @@ library
3333 Roboservant.Types.Breakdown
3434 Roboservant.Types.BuildFrom
3535 Roboservant.Types.FlattenServer
36− Roboservant.Types.GBuildFrom
3736 Roboservant.Types.Internal
3837 Roboservant.Types.ReifiedApi
3938 other-modules:
@@ -67,10 +66,10 @@ test-suite roboservant-test
6766 type: exitcode-stdio-1.0
6867 main-is: Spec.hs
6968 other-modules:
70− BuildFrom
7169 Foo
7270 Headers
7371 Post
72+ Product
7473 Seeded
7574 UnsafeIO
7675 Valid
src/Roboservant/Types/BuildFrom.hs+18
@@ -2,6 +2,7 @@
22{-# LANGUAGE TypeFamilies #-}
33{-# LANGUAGE StandaloneDeriving #-}
44{-# LANGUAGE DerivingVia #-}
5+{-# LANGUAGE TypeApplications #-}
56{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE UndecidableInstances #-}
78{-# LANGUAGE PolyKinds #-}
@@ -17,6 +18,7 @@
1718
1819module Roboservant.Types.BuildFrom where
1920
21+import Control.Monad(filterM)
2022import Data.List.NonEmpty (NonEmpty(..))
2123import qualified Data.List.NonEmpty as NEL
2224import Data.Typeable (Typeable)
@@ -68,9 +70,20 @@ deriving via (Atom Bool) instance BuildFrom Bool
6870
6971deriving via (Compound (Maybe x)) instance (Typeable x, Hashable x, BuildFrom x) => BuildFrom (Maybe x)
7072
73+-- this isn't wonderful, but we need a hand-rolled instance for recursive datatypes right now.
74+-- with an arbitrary-ish interface, we could use a size parameter, rng access etc.
75+instance (BuildFrom x) => BuildFrom [x] where
76+ extras stash = map (\xs -> (concatMap fst xs,map snd xs)) $ powerset $ take 3 $ extras @x stash
77+ where
78+ powerset xs = filterM (\_ -> [True, False]) xs
79+
7180instance (Hashable x, Typeable x, Generic x, GBuildFrom (Rep x)) => BuildFrom (Compound (x::Type)) where
7281 extras stash = fmap (Compound . to) <$> gExtras stash
7382
83+deriving via (Atom Int) instance BuildFrom Int
84+deriving via (Atom Char) instance BuildFrom Char
85+
86+
7487class GBuildFrom (f :: k -> *) where
7588 gExtras :: Stash -> [([Provenance], f a)]
7689
@@ -82,6 +95,11 @@ instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :+: b) where
8295 gExtras stash = (fmap L1 <$> gExtras stash)
8396 <> (fmap R1 <$> gExtras stash)
8497
98+instance (GBuildFrom a, GBuildFrom b) => GBuildFrom (a :*: b) where
99+ gExtras stash = [ (pa<>pb, a' :*: b') | (pa,a') <- gExtras stash , (pb,b') <- gExtras stash]
100+
101+
102+
85103
86104instance GBuildFrom b => GBuildFrom (M1 C a b) where
87105 gExtras =fmap (fmap M1) . gExtras
test/Product.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DerivingStrategies #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TypeOperators #-}
7+
8+module Product where
9+
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+type Api = "item" :> ReqBody '[JSON] Foo :> Post '[JSON] ()
24+
25+eliminate :: Foo -> Handler ()
26+eliminate (Foo _a _b) = throwError $ err500 {errBody = "eliminate blew up, oh no!"}
27+
28+server :: Server Api
29+server = eliminate
test/Spec.hs+25−9
@@ -1,14 +1,10 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE StandaloneDeriving #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−
5−{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE RecordWildCards #-}
64{-# LANGUAGE DerivingVia #-}
7−
85{-# LANGUAGE TypeApplications #-}
96{-# LANGUAGE LambdaCase #-}
107{-# LANGUAGE DerivingVia #-}
11−{-# LANGUAGE StandaloneDeriving #-}
128
139{-# OPTIONS_GHC -fno-warn-orphans #-}
1410import qualified Foo
@@ -16,9 +12,11 @@ import qualified Seeded
1612import qualified Valid
1713import qualified Headers
1814import qualified Post
15+import qualified Product
16+
1917import Test.Hspec.Core.Spec
2018
21−import Data.Dynamic(toDyn)
19+import Data.Dynamic(toDyn,Typeable,Dynamic)
2220import qualified Roboservant as RS
2321import Test.Hspec
2422import Data.Void
@@ -72,12 +70,28 @@ spec = do
7270 describe "Foo" $ do
7371 it "finds an error in a basic app" $
7472 RS.fuzz @Foo.Api Foo.server defaultConfig noCheck
75− >>= (`shouldSatisfy` isJust)
73+ >>= (`shouldSatisfy` serverFailure)
7674
77− describe "headers" $ do
75+ describe "headers (and sum types)" $ do
7876 it "should find a failure that's dependent on using header info" $ do
7977 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
80− >>= (`shouldSatisfy` isJust)
78+ >>= (`shouldSatisfy` serverFailure)
79+
80+ describe "product types" $ do
81+ 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
83+ >>= (`shouldSatisfy` serverFailure)
84+ -- >>= (`shouldSatisfy` isJust)
85+
86+hashedDyn :: (Hashable a, Typeable a) => a -> (Dynamic, Int)
87+hashedDyn a = (toDyn a, hash a)
88+
89+serverFailure :: Maybe RS.Report -> Bool
90+serverFailure = \case
91+ Just RS.Report{..} ->
92+ let RS.RoboservantException{..} = rsException
93+ in failureReason /= RS.NoPossibleMoves
94+ _ -> False
8195
8296 -- describe "can build from pieces" $ do
8397 -- it "should find a failure that requires some assembly" $ do
@@ -118,6 +132,8 @@ deriving via (RS.Atom Void) instance RS.BuildFrom Void
118132deriving via (RS.Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
119133deriving via (RS.Atom Post.FooPost) instance RS.Breakdown Post.FooPost
120134
135+deriving via (RS.Compound Product.Foo) instance RS.BuildFrom Product.Foo
136+
121137
122138--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.BuildFrom RS.BuildFrom.Wrapped
123139--deriving via (Compound RS.BuildFrom.Wrapped) instance RS.Breakdown RS.BuildFrom.Wrapped