git.iko.soy/roboservant
on master help sign in
broken wip
bbba055Mark Wotton
src/Roboservant/Direct.hs+5−4
compare with master
unifiedsplit
@@ -73,7 +73,6 @@ data RoboservantException
73 = RoboservantException
73 = RoboservantException
74 { failureReason :: FailureType
74 { failureReason :: FailureType
75 , serverException :: Maybe SomeException
75 , serverException :: Maybe SomeException
76− , something :: Int
77 , fuzzState :: FuzzState
76 , fuzzState :: FuzzState
78 } deriving (Show)
77 } deriving (Show)
79
78
@@ -151,9 +150,11 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
151 mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
150 mapM_ print (Set.toList $ Set.fromList $ map apiOffset path)
152 putStrLn ""
151 putStrLn ""
153 putStrLn "types in stash"
152 putStrLn "types in stash"
153+ DM.forWithKey_ (getStash stash) $ \k v ->
154+ print (k,NEL.length $ getStashValue v)
154− mapM_
155+ -- mapM_
155− (print . second NEL.length)
156+ -- (print . second NEL.length)
156− (sortOn (show . fst) . Map.toList stash)
157+ -- (sortOn (show . fst) $ Map.toList $ getStash stash)
157
158
158 -- evaluateCoverage :: FuzzState -> m ()
159 -- evaluateCoverage :: FuzzState -> m ()
159 evaluateCoverage f@FuzzState{..}
160 evaluateCoverage f@FuzzState{..}
src/Roboservant/Types/Breakdown.hs+5−21
@@ -25,10 +25,7 @@ import Data.List.NonEmpty (NonEmpty(..))
25import qualified Data.List.NonEmpty as NEL
25import qualified Data.List.NonEmpty as NEL
26import qualified Data.Map.Strict as Map
26import qualified Data.Map.Strict as Map
27import Data.Maybe (fromMaybe)
27import Data.Maybe (fromMaybe)
28−import Data.Proxy (Proxy (..))
29−import Data.Typeable (TypeRep, Typeable, typeRep)
30import GHC.Generics(Generic)
28import GHC.Generics(Generic)
31−import qualified GHC.Generics as Generics
32import Data.Typeable (Typeable)
29import Data.Typeable (Typeable)
33import qualified Data.Dependent.Map as DM
30import qualified Data.Dependent.Map as DM
34import Data.Dependent.Map (DMap)
31import Data.Dependent.Map (DMap)
@@ -42,9 +39,6 @@ data Provenance
42
39
43class Breakdown x where
40class Breakdown x where
44 breakdown :: x -> NonEmpty Dynamic
41 breakdown :: x -> NonEmpty Dynamic
45−-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
46−-- breakdown = pure . toDyn
47−
48
42
49-- | Can't be built up from parts
43-- | Can't be built up from parts
50newtype Atom x = Atom { unAtom :: x }
44newtype Atom x = Atom { unAtom :: x }
@@ -55,15 +49,15 @@ newtype Compound x = Compound { unCompound :: x }
55-- | so, this is quite tricky. we need to witness the structure of `x`, but
49-- | so, this is quite tricky. we need to witness the structure of `x`, but
56-- we don't have an example of it yet. not entirely sure where to go.
50-- we don't have an example of it yet. not entirely sure where to go.
57instance (Typeable x, Generic x) => BuildFrom (Compound x) where
51instance (Typeable x, Generic x) => BuildFrom (Compound x) where
58− buildFrom stash = error "oops"
52+ buildFrom _stash = error "oops"
59-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
53-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
60
54
61−-- | this should be a bit more tractable.
55+-- -- | this should be a bit more tractable.
62−instance (Typeable x, Generic x) => Breakdown (Compound x) where
56+-- instance (Typeable x, Generic x) => Breakdown (Compound x) where
63− breakdown x = _ . Generics.from . unCompound $ x
57+-- breakdown x = _ . Generics.from . unCompound $ x
64
58
65instance Typeable x => BuildFrom (Atom x) where
59instance Typeable x => BuildFrom (Atom x) where
66− buildFrom = Map.lookup (typeRep (Proxy @x))
60+ buildFrom = DM.lookup R.typeRep . getStash
67
61
68newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
62newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
69 deriving (Functor, Show)
63 deriving (Functor, Show)
@@ -79,21 +73,11 @@ instance Show Stash where
79
73
80class Typeable x => BuildFrom (x :: Type) where
74class Typeable x => BuildFrom (x :: Type) where
81 buildFrom :: Stash -> Maybe (StashValue x)
75 buildFrom :: Stash -> Maybe (StashValue x)
82− default buildFrom :: Stash -> Maybe (StashValue x)
83− buildFrom = DM.lookup R.typeRep . getStash
84−
85− -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
86−
87−
88−-- baseLookup :: TypeRep -> Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
89−-- baseLookup tr mmm = -- Map.lookup (typeRep (Proxy @x)) mmm
90−-- Map.lookup tr mmm
91
76
92-- | only use this when we are using the internal typerep map.
77-- | only use this when we are using the internal typerep map.
93promisedDyn :: Typeable a => Dynamic -> a
78promisedDyn :: Typeable a => Dynamic -> a
94promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
79promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
95
80
96−-- instance BuildFrom Bool
97deriving via (Atom Bool) instance BuildFrom Bool
81deriving via (Atom Bool) instance BuildFrom Bool
98
82
99instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
83instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
stack.yaml+6−1
@@ -1,4 +1,5 @@
1−resolver: lts-16.8 #lts-16.16
1+# nb: 16.8 doesn't work because the version of servant is too old to have FoldLenient', fixme.
2+resolver: lts-16.16
2packages:
3packages:
3- .
4- .
4
5
@@ -8,3 +9,7 @@ extra-deps:
8- dependent-sum-0.7.1.0
9- dependent-sum-0.7.1.0
9- constraints-extras-0.3.0.2
10- constraints-extras-0.3.0.2
10- dependent-map-0.4.0.0
11- dependent-map-0.4.0.0
12+- servant-0.18.2
13+- servant-client-0.18.2
14+- servant-client-core-0.18.2
15+- servant-server-0.18.2
test/Spec.hs+6−6
@@ -63,10 +63,10 @@ spec = do
63 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
63 RS.fuzz @Headers.Api Headers.server defaultConfig noCheck
64 >>= (`shouldSatisfy` isJust)
64 >>= (`shouldSatisfy` isJust)
65
65
66− describe "can build from pieces" $ do
66+ -- describe "can build from pieces" $ do
67− it "should find a failure that requires some assembly" $ do
67+ -- it "should find a failure that requires some assembly" $ do
68− RS.fuzz @BuildFrom.Api BuildFrom.server defaultConfig noCheck
68+ -- RS.fuzz @BuildFrom.Api BuildFrom.server defaultConfig noCheck
69− >>= (`shouldSatisfy` isJust)
69+ -- >>= (`shouldSatisfy` isJust)
70
70
71
71
72
72
@@ -103,8 +103,8 @@ deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
103deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
103deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
104
104
105
105
106−deriving via (Compound BuildFrom.Wrapped) instance RS.BuildFrom BuildFrom.Wrapped
106+--deriving via (Compound BuildFrom.Wrapped) instance RS.BuildFrom BuildFrom.Wrapped
107−deriving via (Compound BuildFrom.Wrapped) instance RS.Breakdown BuildFrom.Wrapped
107+--deriving via (Compound BuildFrom.Wrapped) instance RS.Breakdown BuildFrom.Wrapped
108
108
109
109
110
110