780fb79 · roboservant · git.iko.soy

git.iko.soy/roboservant

on master help sign in

Merge branch 'derivingvia' into morecoverage

780fb79Mark Wotton6 years ago

roboservant.cabal+3−1

compare with master

unifiedsplit

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

4--

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

6--

7−-- hash: 134cfee817f86824342ecabc02ca2b48ec67539b75581c1954b95a9f9128e5a4

7+-- hash: 6420e658218cfbfe27ae6037534f3e63a37fb1c9dfbd1a48c5f5e435d959a5af

9name: roboservant

10version: 0.1.0.2

@@ -31,7 +31,9 @@ library

31 Roboservant.Direct

32 Roboservant.Types

33 Roboservant.Types.Breakdown

34+ Roboservant.Types.BuildFrom

34 Roboservant.Types.FlattenServer

35 Roboservant.Types.FlattenServer

36+ Roboservant.Types.Internal

35 Roboservant.Types.ReifiedApi

37 Roboservant.Types.ReifiedApi

36 other-modules:

38 other-modules:

37 Paths_roboservant

39 Paths_roboservant

src/Roboservant.hs+2−2

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

1module Roboservant (module Roboservant.Direct

2− ,module Roboservant.Types.Breakdown) where

2+ ,module Roboservant.Types) where

4import Roboservant.Direct

5−import Roboservant.Types.Breakdown

5+import Roboservant.Types

src/Roboservant/Direct.hs+129−105

@@ -1,11 +1,7 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DerivingStrategies #-}

4{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

7{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE PolyKinds #-}

9{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

@@ -48,25 +44,36 @@ import System.Timeout.Lifted(timeout)

48import GHC.Generics ((:*:)(..))

44import GHC.Generics ((:*:)(..))

49import qualified Data.Vinyl.Functor as V

45import qualified Data.Vinyl.Functor as V

50import qualified Data.Vinyl.Curry as V

46import qualified Data.Vinyl.Curry as V

47+

48+

49+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)

50+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)

51+import Control.Monad.Trans.Control (MonadBaseControl)

51import qualified Data.Dependent.Map as DM

52import qualified Data.Dependent.Map as DM

52−import qualified Data.Vinyl as V

53+import Data.Dynamic (Dynamic (..), dynTypeRep)

54+import Data.List.NonEmpty (NonEmpty (..))

53import qualified Data.List.NonEmpty as NEL

55import qualified Data.List.NonEmpty as NEL

56+import Data.Maybe (mapMaybe)

54−import qualified Data.Map.Strict as Map

57+import qualified Data.Set as Set

55import Data.Time.Clock

58import Data.Time.Clock

56−import qualified Type.Reflection as R

59+import qualified Data.Vinyl as V

57−

60+import qualified Data.Vinyl.Curry as V

58−import Roboservant.Types.Breakdown

61+import qualified Data.Vinyl.Functor as V

62+import GHC.Generics ((:*:) (..))

59import Roboservant.Types

63import Roboservant.Types

60 ( ApiOffset (..),

64 ( ApiOffset (..),

65+ Argument (..),

61 FlattenServer (..),

66 FlattenServer (..),

62−-- ReifiedApi,

67+ Provenance (..),

68+ ReifiedEndpoint (..),

69+ Stash (..),

70+ StashValue (..),

63 ToReifiedApi (..),

71 ToReifiedApi (..),

64−

65− ReifiedEndpoint(..),

66− Argument(..),

67 TypedF

72 TypedF

68−

69 )

73 )

74+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))

75+import System.Random (StdGen, mkStdGen, randomR)

76+import qualified Type.Reflection as R

72data RoboservantException

79data RoboservantException

@@ -85,57 +92,64 @@ data FailureType

85 | InsufficientCoverage Double

92 | InsufficientCoverage Double

86 deriving (Show,Eq)

93 deriving (Show,Eq)

88−

89−data FuzzOp = FuzzOp

95+data FuzzOp

96+ = FuzzOp

90− { apiOffset :: ApiOffset

97+ { apiOffset :: ApiOffset,

91− , provenance :: [Provenance]

98+ provenance :: [Provenance]

99+ }

92− } deriving (Show,Eq)

100+ deriving (Show, Eq)

101

94data Config

102data Config

95 = Config

103 = Config

96− { seed :: [Dynamic]

104+ { seed :: [Dynamic],

97− , maxRuntime :: Integer -- seconds to test for

105+ maxRuntime :: Integer, -- seconds to test for

98− , maxReps :: Integer

106+ maxReps :: Integer,

99− , rngSeed :: Int

107+ rngSeed :: Int,

100− , coverageThreshold :: Double

108+ coverageThreshold :: Double

101− }

109+ }

102−

110+

103−data FuzzState = FuzzState

111+data FuzzState

112+ = FuzzState

104− { path :: [FuzzOp]

113+ { path :: [FuzzOp],

105− , stash :: Stash

114+ stash :: Stash,

106− , currentRng :: StdGen

115+ currentRng :: StdGen

107− }

116+ }

108− deriving Show

117+ deriving (Show)

109

118

119+data EndpointOption

120+ = forall as.

110−data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption

121+ (V.RecordToList as, V.RMap as) =>

122+ EndpointOption

111− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

123+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),

112− , eoArgs :: V.Rec (TypedF StashValue) as

124+ eoArgs :: V.Rec (TypedF StashValue) as

113− }

125+ }

114

126

115data StopReason

127data StopReason

116 = TimedOut

128 = TimedOut

117 | HitMaxIterations

129 | HitMaxIterations

118− deriving (Show,Eq)

130+ deriving (Show, Eq)

119

131

120data Report = Report

132data Report = Report

121 { textual :: String

133 { textual :: String

122 , rsException :: RoboservantException}

134 , rsException :: RoboservantException}

123 deriving (Show)

135 deriving (Show)

124

136

137+fuzz ::

138+ forall api.

125−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))

139+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>

126− => Server api

140+ Server api ->

127− -> Config

141+ Config ->

128− -> IO ()

142+ IO () ->

129− -> IO (Maybe Report)

143+ IO (Maybe Report)

130−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

144+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do

131 let path = []

145 let path = []

132 stash = addToStash seed mempty

146 stash = addToStash seed mempty

133 currentRng = mkStdGen rngSeed

147 currentRng = mkStdGen rngSeed

134−

135− print ("Initial seed", seed, stash)

136 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime

148 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime

137− (stopreason, fs ) <- runStateT

149+ (stopreason, _fs) <-

150+ runStateT

138− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}

151+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))

152+ FuzzState {..}

139 print stopreason

153 print stopreason

140 pure Nothing

154 pure Nothing

141 where

155 where

@@ -174,9 +188,8 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

174 if now > deadline

188 if now > deadline

175 then pure TimedOut

189 then pure TimedOut

176 else do

190 else do

177− action

191+ _ <- action

178− untilDone (n-1, deadline) action

192+ untilDone (n -1, deadline) action

179−

180 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

193 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))

181 routeCount = length reifiedApi

194 routeCount = length reifiedApi

182

195

@@ -185,51 +198,58 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

185 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get

198 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing =<< get

186 elementOrFail l = do

199 elementOrFail l = do

187 st <- get

200 st <- get

188− let (index,newGen) = randomR (0, length l - 1) (currentRng st)

201+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)

189− modify' $ \st' -> st' { currentRng = newGen }

202+ modify' $ \st' -> st' {currentRng = newGen}

190 pure (l !! index)

203 pure (l !! index)

191−

204+ withOp ::

192− withOp :: (MonadState FuzzState m, MonadIO m)

205+ (MonadState FuzzState m, MonadIO m) =>

206+ ( forall as.

193− => (forall as. (V.RecordToList as, V.RMap as)

207+ (V.RecordToList as, V.RMap as) =>

194− => FuzzOp

208+ FuzzOp ->

195− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

209+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->

196− -> V.Rec (TypedF V.Identity) as -> m r

210+ V.Rec (TypedF V.Identity) as ->

211+ m r

197− )

212+ ) ->

198− -> m r

213+ m r

199 withOp callback = do

214 withOp callback = do

200 -- choose a call to make, from the endpoints with fillable arguments.

215 -- choose a call to make, from the endpoints with fillable arguments.

201− (offset, EndpointOption{..}) <- elementOrFail . options =<< get

216+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get

217+ r <-

202− r <- V.rtraverse

218+ V.rtraverse

203− (\(tr :*: StashValue svs) -> elementOrFail $

219+ ( \(tr :*: StashValue svs) ->

220+ elementOrFail $

221+ zipWith

204− zipWith (\i xy -> V.Const i :*: tr :*: xy)

222+ (\i xy -> V.Const i :*: tr :*: xy)

205− [0..]

223+ [0 ..]

206− (NEL.toList svs)

224+ (NEL.toList svs)

207− )

225+ )

208− eoArgs

226+ eoArgs

209− let pathSegment = FuzzOp offset $

227+ let pathSegment =

228+ FuzzOp offset $

210− recordToList'

229+ recordToList'

211− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)

230+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)

231+ r

232+ argValues =

233+ V.rmap

234+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)

212 r

235 r

213− argValues = V.rmap

214− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)

215− r

216− modify' (\f -> f { path = path f <> [pathSegment] })

236+ modify' (\f -> f {path = path f <> [pathSegment]})

217 callback pathSegment eoCall argValues

237 callback pathSegment eoCall argValues

218 where

238 where

219 options :: FuzzState -> [(ApiOffset, EndpointOption)]

239 options :: FuzzState -> [(ApiOffset, EndpointOption)]

220− options FuzzState{..} =

240+ options FuzzState {..} =

221 mapMaybe

241 mapMaybe

222− ( \(offset, ReifiedEndpoint{..}) -> do

242+ ( \(offset, ReifiedEndpoint {..}) -> do

223− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments

243+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments

224− pure (offset, EndpointOption reEndpointFunc args)

244+ pure (offset, EndpointOption reEndpointFunc args)

225 )

245 )

226 reifiedApi

246 reifiedApi

227−

247+ execute ::

228− execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)

248+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>

229− => FuzzOp

249+ FuzzOp ->

230− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))

250+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->

231− -> V.Rec (TypedF V.Identity) as

251+ V.Rec (TypedF V.Identity) as ->

232− -> m ()

252+ m ()

233 execute fuzzop func args = do

253 execute fuzzop func args = do

234 (liftIO . print . (fuzzop,) . stash ) =<< get

254 (liftIO . print . (fuzzop,) . stash ) =<< get

235 st <- get

255 st <- get

@@ -247,7 +267,7 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

247 case errHTTPCode serverError of

267 case errHTTPCode serverError of

248 500 -> throw serverError

268 500 -> throw serverError

249 _ -> do

269 _ -> do

250− liftIO $ print ("ignoring non-500 error" , serverError)

270+ liftIO $ print ("ignoring non-500 error", serverError)

251 Right (dyn :: NEL.NonEmpty Dynamic) -> do

271 Right (dyn :: NEL.NonEmpty Dynamic) -> do

252 -- liftIO $ print ("storing", fmap dynTypeRep dyn)

272 -- liftIO $ print ("storing", fmap dynTypeRep dyn)

253 modify' (\fs@FuzzState{..} ->

273 modify' (\fs@FuzzState{..} ->

@@ -255,9 +275,9 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

255 where

275 where

256 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

276 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args

257 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

277 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args

258−

278+ go ::

259− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)

279+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>

260− => m ()

280+ m ()

261 go = withOp $ \op func args -> do

281 go = withOp $ \op func args -> do

262 catches (execute op func args)

282 catches (execute op func args)

263 [ Handler (\(e :: SomeAsyncException) -> throw e)

283 [ Handler (\(e :: SomeAsyncException) -> throw e)

@@ -268,29 +288,33 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do

268 catch (liftIO checker)

288 catch (liftIO checker)

269 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

289 (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) =<< get)

270

290

271−addToStash :: [Dynamic]

291+addToStash ::

272− -> Stash

292+ [Dynamic] ->

293+ Stash ->

273− -> Stash

294+ Stash

274addToStash result stash =

295addToStash result stash =

296+ foldr

275− foldr (\(Dynamic tr x) (Stash dict) -> Stash $

297+ ( \(Dynamic tr x) (Stash dict) ->

298+ Stash $

276− DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict

299+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| [])) dict

277 )

300 )

278 stash

301 stash

279 result

302 result

280 where

303 where

304+ renumber ::

281− renumber :: StashValue a

305+ StashValue a ->

282− -> StashValue a

306+ StashValue a ->

283− -> StashValue a

307+ StashValue a

284 renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of

308 renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of

285− [([Provenance tr _], dyn)] -> l

309+ [([Provenance tr _], dyn)] ->

310+ l

286− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

311+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)

287 _ -> error "should be impossible"

312 _ -> error "should be impossible"

288

313

289−

290-- why isn't this in vinyl?

314-- why isn't this in vinyl?

291−recordToList'

315+recordToList' ::

292− :: (V.RecordToList as, V.RMap as)

316+ (V.RecordToList as, V.RMap as) =>

293− => (forall x. f x -> a)

317+ (forall x. f x -> a) ->

294− -> V.Rec f as

318+ V.Rec f as ->

295− -> [a]

319+ [a]

296recordToList' f = V.recordToList . V.rmap (V.Const . f)

320recordToList' f = V.recordToList . V.rmap (V.Const . f)

src/Roboservant/Types.hs+5

@@ -15,11 +15,16 @@

16module Roboservant.Types

17 ( module Roboservant.Types.Breakdown

18+ , module Roboservant.Types.BuildFrom

18 , module Roboservant.Types.FlattenServer

19 , module Roboservant.Types.FlattenServer

19 , module Roboservant.Types.ReifiedApi

20 , module Roboservant.Types.ReifiedApi

21+ , module Roboservant.Types.Internal

22+

20 )

23 )

21where

24where

23import Roboservant.Types.Breakdown

26import Roboservant.Types.Breakdown

27+import Roboservant.Types.BuildFrom

24import Roboservant.Types.FlattenServer

28import Roboservant.Types.FlattenServer

25import Roboservant.Types.ReifiedApi

29import Roboservant.Types.ReifiedApi

30+import Roboservant.Types.Internal

src/Roboservant/Types/Breakdown.hs+11−69

@@ -5,7 +5,6 @@

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE DefaultSignatures #-}

8−{-# LANGUAGE DeriveFunctor #-}

9{-# LANGUAGE DerivingStrategies #-}

8{-# LANGUAGE DerivingStrategies #-}

10{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

11{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GADTs #-}

@@ -17,92 +16,35 @@

17{-# LANGUAGE TypeApplications #-}

16{-# LANGUAGE TypeApplications #-}

18{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeFamilies #-}

19{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

19+{-# LANGUAGE StandaloneDeriving #-}

20+{-# LANGUAGE DerivingVia #-}

21+

21module Roboservant.Types.Breakdown where

23module Roboservant.Types.Breakdown where

23import Data.Dynamic (Dynamic, fromDynamic, toDyn)

25import Data.Dynamic (Dynamic, fromDynamic, toDyn)

24−import Data.List.NonEmpty (NonEmpty(..))

26+import Data.List.NonEmpty (NonEmpty (..))

25import qualified Data.List.NonEmpty as NEL

27import qualified Data.List.NonEmpty as NEL

26−import qualified Data.Map.Strict as Map

27import Data.Maybe (fromMaybe)

28import Data.Maybe (fromMaybe)

28import GHC.Generics(Generic)

29import GHC.Generics(Generic)

29import Data.Typeable (Typeable)

30import Data.Typeable (Typeable)

30−import qualified Data.Dependent.Map as DM

31+import Roboservant.Types.Internal

31−import Data.Dependent.Map (DMap)

32−import qualified Type.Reflection as R

33−import Data.Dependent.Sum

34−import Data.Kind

36−data Provenance

33+-- | only use this when we are using the internal typerep map.

37− = Provenance R.SomeTypeRep Int

34+promisedDyn :: Typeable a => Dynamic -> a

38− deriving (Show,Eq)

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

40class Breakdown x where

37class Breakdown x where

41 breakdown :: x -> NonEmpty Dynamic

38 breakdown :: x -> NonEmpty Dynamic

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

40+-- breakdown = pure . toDyn

43−-- | Can't be built up from parts

44−newtype Atom x = Atom { unAtom :: x }

45−

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

47−newtype Compound x = Compound { unCompound :: x }

48−

49−-- | so, this is quite tricky. we need to witness the structure of `x`, but

50−-- we don't have an example of it yet. not entirely sure where to go.

51−instance (Typeable x, Generic x) => BuildFrom (Compound x) where

52− buildFrom _stash = error "oops"

53−-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from

54−

55−-- -- | this should be a bit more tractable.

56−-- instance (Typeable x, Generic x) => Breakdown (Compound x) where

57−-- breakdown x = _ . Generics.from . unCompound $ x

59instance Typeable x => Breakdown (Atom x) where

43instance Typeable x => Breakdown (Atom x) where

60− breakdown = pure . toDyn

44+ breakdown = pure . toDyn . unAtom

61−

62−-- instance Typeable a => Breakdown (Atom a) where

63−-- breakdown = pure . toDyn . unAtom

64−

65−

66−instance Typeable x => BuildFrom (Atom x) where

67− buildFrom = DM.lookup R.typeRep . getStash

68−

69−newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }

70− deriving (Functor, Show)

71−

72−-- wrap in newtype to give a custom Show instance, since the normal

73−-- instance for DMap is not happy since StashValue needs Show a to show

74−newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }

75− deriving (Semigroup, Monoid)

76−

77−instance Show Stash where

78− showsPrec i (Stash x) = showsPrec i $

79− Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x

80−

81−class Typeable x => BuildFrom (x :: Type) where

82− buildFrom :: Stash -> Maybe (StashValue x)

83−

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

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

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

87−

88−deriving via (Atom Bool) instance BuildFrom Bool

89−

90−instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

91− buildFrom dict = Just options

92− where options :: StashValue (Maybe x)

93− options = StashValue $

94− ([],Nothing) :|

95− (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict

96− )

98deriving via (Atom ()) instance Breakdown ()

46deriving via (Atom ()) instance Breakdown ()

99deriving via (Atom Int) instance Breakdown Int

47deriving via (Atom Int) instance Breakdown Int

100

101−

102−

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

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

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

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

105−

106−instance (BuildFrom a) => BuildFrom [a] where

107− buildFrom = error "fuuuck"

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

src/Roboservant/Types/BuildFrom.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE DerivingStrategies #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE DerivingVia #-}

10+

11+module Roboservant.Types.BuildFrom where

12+

13+import Data.List.NonEmpty (NonEmpty(..))

14+import qualified Data.List.NonEmpty as NEL

15+import Data.Typeable (Typeable)

16+import qualified Data.Dependent.Map as DM

17+import qualified Type.Reflection as R

18+import Data.Kind

19+import Roboservant.Types.Internal

20+

21+class Typeable x => BuildFrom (x :: Type) where

22+ buildFrom :: Stash -> Maybe (StashValue x)

23+

24+-- | this is a little esoteric: basically, we're always going to use this with

25+-- deriving-via, so we need to look up the underlying `x` and then wrap it in Atom.

26+instance Typeable x => BuildFrom (Atom x) where

27+ buildFrom = fmap (fmap Atom) <$> DM.lookup R.typeRep . getStash

28+

29+deriving via (Atom Bool) instance BuildFrom Bool

30+

31+instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where

32+ buildFrom dict = Just options

33+ where options :: StashValue (Maybe x)

34+ options = StashValue $

35+ ([],Nothing) :|

36+ (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict

37+ )

38+-- instance (BuildFrom a) => BuildFrom [a] -- where

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

src/Roboservant/Types/Internal.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4+module Roboservant.Types.Internal where

6+import Data.List.NonEmpty (NonEmpty(..))

7+import qualified Data.Map.Strict as Map

8+import qualified Data.Dependent.Map as DM

9+import Data.Dependent.Map (DMap)

10+import qualified Type.Reflection as R

11+import Data.Dependent.Sum

12+

13+data Provenance

14+ = Provenance R.SomeTypeRep Int

15+ deriving (Show,Eq)

16+

17+newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }

18+ deriving (Functor, Show)

19+

20+-- wrap in newtype to give a custom Show instance, since the normal

21+-- instance for DMap is not happy since StashValue needs Show a to show

22+newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }

23+ deriving (Semigroup, Monoid)

24+

25+instance Show Stash where

26+ showsPrec i (Stash x) = showsPrec i $

27+ Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x

28+

29+-- | Can't be built up from parts, can't be broken down further.

30+newtype Atom x = Atom { unAtom :: x }

31+

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

33+newtype Compound x = Compound { unCompound :: x }

src/Roboservant/Types/ReifiedApi.hs+2

@@ -29,7 +29,9 @@ import Data.List.NonEmpty (NonEmpty)

29import Data.Typeable (Typeable)

30import GHC.Generics ((:*:)(..))

31import GHC.TypeLits (Symbol)

32+import Roboservant.Types.Internal

32import Roboservant.Types.Breakdown

33import Roboservant.Types.Breakdown

34+import Roboservant.Types.BuildFrom

33import Roboservant.Types.FlattenServer

35import Roboservant.Types.FlattenServer

34import Servant

36import Servant

35import Servant.API.Modifiers(FoldRequired,FoldLenient)

37import Servant.API.Modifiers(FoldRequired,FoldLenient)

test/Spec.hs+3−1

@@ -3,6 +3,9 @@

3{-# LANGUAGE DerivingVia #-}

4{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE DerivingVia #-}

7+{-# LANGUAGE StandaloneDeriving #-}

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

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

7import qualified Foo

10import qualified Foo

8import qualified Seeded

11import qualified Seeded

@@ -16,7 +19,6 @@ import Data.Dynamic(toDyn)

16import qualified Roboservant as RS

19import qualified Roboservant as RS

17import Roboservant(Breakdown, BuildFrom, Atom, Compound)

20import Roboservant(Breakdown, BuildFrom, Atom, Compound)

18import Test.Hspec

21import Test.Hspec

19−import Test.Hspec.Core.Spec

20import Data.Void

22import Data.Void

21import Data.Maybe

23import Data.Maybe