git.iko.soy/roboservant
on master help sign in
cleanup
1f3a834Mark Wotton
roboservant.cabal+3−1
compare with master
unifiedsplit
@@ -4,7 +4,7 @@ cabal-version: 1.12
4--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6--
6--
7−-- hash: 49f8c03988a25b7e35dddaab65f250955a078392aaa293298885aea164315479
7+-- hash: a0f650472f077eb44b9eefc36c90786ca0e371f2dc596f9a5d4e0e808ddc0396
8
8
9name: roboservant
9name: roboservant
10version: 0.1.0.2
10version: 0.1.0.2
@@ -31,7 +31,9 @@ library
31 Roboservant.Direct
31 Roboservant.Direct
32 Roboservant.Types
32 Roboservant.Types
33 Roboservant.Types.Breakdown
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
1module Roboservant (module Roboservant.Direct
2− ,module Roboservant.Types.Breakdown) where
2+ ,module Roboservant.Types) where
3
3
4import Roboservant.Direct
4import Roboservant.Direct
5−import Roboservant.Types.Breakdown
5+import Roboservant.Types
src/Roboservant/Direct.hs+174−166
@@ -1,73 +1,57 @@
1{-# LANGUAGE AllowAmbiguousTypes #-}
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 GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE RecordWildCards #-}
12{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TupleSections #-}
15{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19
10
20module Roboservant.Direct
11module Roboservant.Direct
12+ ( fuzz,
21− ( fuzz, Config(..)
13+ Config (..),
22−
23− -- TODO come up with something smarter than exporting all this, we should
14+ -- TODO come up with something smarter than exporting all this, we should
24− -- have some nice error-display functions
15+ -- have some nice error-display functions
25− , RoboservantException(..), FuzzState(..), FuzzOp(..)
16+ RoboservantException (..),
17+ FuzzState (..),
18+ FuzzOp (..),
26 )
19 )
27where
20where
28
21
29−import Control.Exception.Lifted(throw,handle,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
22+import Control.Exception.Lifted (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, handle, throw)
30−import Control.Monad(void,replicateM)
31−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,runStateT)
23+import Control.Monad.State.Strict (MonadIO, MonadState, get, liftIO, modify', runStateT)
32−import Control.Exception.Lifted(throw,Handler(..), Exception,SomeException,SomeAsyncException, catch, catches)
33−import Control.Monad(void,replicateM,forM_)
34−import Control.Monad.State.Strict(MonadState,MonadIO,get,modify',liftIO,execStateT)
35−import Control.Monad.Trans.Control(MonadBaseControl)
24+import Control.Monad.Trans.Control (MonadBaseControl)
36−import Data.Dependent.Map (DMap)
37−import Data.Dynamic (Dynamic(..), dynApply, dynTypeRep, fromDynamic)
38−import Data.List.NonEmpty (NonEmpty(..))
39−import Data.Map.Strict(Map)
40−import qualified Data.Set as Set
41−import Data.Maybe (mapMaybe)
42−import Data.Typeable (TypeRep)
43−import Servant (Endpoints, Proxy (Proxy), Server, ServerError(..))
44−import System.Random(StdGen,randomR,mkStdGen)
45−import System.Timeout.Lifted(timeout)
46−import GHC.Generics ((:*:)(..))
47−import qualified Data.Vinyl.Functor as V
48−import qualified Data.Vinyl.Curry as V
49import qualified Data.Dependent.Map as DM
25import qualified Data.Dependent.Map as DM
50−import qualified Data.Vinyl as V
26+import Data.Dynamic (Dynamic (..), dynTypeRep)
27+import Data.List.NonEmpty (NonEmpty (..))
51import qualified Data.List.NonEmpty as NEL
28import qualified Data.List.NonEmpty as NEL
29+import Data.Maybe (mapMaybe)
52−import qualified Data.Map.Strict as Map
30+import qualified Data.Set as Set
53import Data.Time.Clock
31import Data.Time.Clock
54−import qualified Type.Reflection as R
32+import qualified Data.Vinyl as V
55−
33+import qualified Data.Vinyl.Curry as V
56−import Roboservant.Types.Breakdown
34+import qualified Data.Vinyl.Functor as V
35+import GHC.Generics ((:*:) (..))
57import Roboservant.Types
36import Roboservant.Types
58 ( ApiOffset (..),
37 ( ApiOffset (..),
38+ Argument (..),
59 FlattenServer (..),
39 FlattenServer (..),
60−-- ReifiedApi,
40+ Provenance (..),
41+ ReifiedEndpoint (..),
42+ Stash (..),
43+ StashValue (..),
61 ToReifiedApi (..),
44 ToReifiedApi (..),
62− ReifiedEndpoint(..),
63− Argument(..),
64− TypedF
45+ TypedF,
65−
66 )
46 )
47+import Servant (Endpoints, Proxy (Proxy), Server, ServerError (..))
48+import System.Random (StdGen, mkStdGen, randomR)
49+import qualified Type.Reflection as R
67
50
68data RoboservantException
51data RoboservantException
69 = RoboservantException FailureType (Maybe SomeException) Int FuzzState
52 = RoboservantException FailureType (Maybe SomeException) Int FuzzState
70 deriving (Show)
53 deriving (Show)
54+
71-- we believe in nussink, lebowski
55-- we believe in nussink, lebowski
72instance Exception RoboservantException
56instance Exception RoboservantException
73
57
@@ -76,148 +60,164 @@ data FailureType
76 | CheckerFailed
60 | CheckerFailed
77 | NoPossibleMoves
61 | NoPossibleMoves
78 | InsufficientCoverage
62 | InsufficientCoverage
79− deriving (Show,Eq)
63+ deriving (Show, Eq)
80
64
81−
82−data FuzzOp = FuzzOp
65+data FuzzOp
66+ = FuzzOp
83− { apiOffset :: ApiOffset
67+ { apiOffset :: ApiOffset,
84− , provenance :: [Provenance]
68+ provenance :: [Provenance]
69+ }
85− } deriving (Show,Eq)
70+ deriving (Show, Eq)
86
71
87data Config
72data Config
88 = Config
73 = Config
89− { seed :: [Dynamic]
74+ { seed :: [Dynamic],
90− , maxRuntime :: Integer -- seconds to test for
75+ maxRuntime :: Integer, -- seconds to test for
91− , maxReps :: Integer
76+ maxReps :: Integer,
92− , rngSeed :: Int
77+ rngSeed :: Int,
93− , coverageThreshold :: Double
78+ coverageThreshold :: Double
94− }
79+ }
95
80
96−data FuzzState = FuzzState
81+data FuzzState
82+ = FuzzState
97− { path :: [FuzzOp]
83+ { path :: [FuzzOp],
98− , stash :: Stash
84+ stash :: Stash,
99− , currentRng :: StdGen
85+ currentRng :: StdGen
100− }
86+ }
101− deriving Show
87+ deriving (Show)
102
88
89+data EndpointOption
90+ = forall as.
103−data EndpointOption = forall as. (V.RecordToList as, V.RMap as) => EndpointOption
91+ (V.RecordToList as, V.RMap as) =>
92+ EndpointOption
104− { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
93+ { eoCall :: V.Curried as (IO (Either ServerError (NonEmpty Dynamic))),
105− , eoArgs :: V.Rec (TypedF StashValue) as
94+ eoArgs :: V.Rec (TypedF StashValue) as
106− }
95+ }
107
96
108data StopReason
97data StopReason
109 = TimedOut
98 = TimedOut
110 | HitMaxIterations
99 | HitMaxIterations
111− deriving (Show,Eq)
100+ deriving (Show, Eq)
112
101
113−data Report = Report
102+data Report
103+ = Report
114− { textual :: String }
104+ {textual :: String}
115− deriving (Show,Eq)
105+ deriving (Show, Eq)
116
106
107+fuzz ::
108+ forall api.
117−fuzz :: forall api. (FlattenServer api, ToReifiedApi (Endpoints api))
109+ (FlattenServer api, ToReifiedApi (Endpoints api)) =>
118− => Server api
110+ Server api ->
119− -> Config
111+ Config ->
120− -> IO ()
112+ IO () ->
121− -> IO (Maybe Report)
113+ IO (Maybe Report)
122−fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
114+fuzz server Config {..} checker = handle (pure . Just . formatException) $ do
123 let path = []
115 let path = []
124 stash = addToStash seed mempty
116 stash = addToStash seed mempty
125 currentRng = mkStdGen rngSeed
117 currentRng = mkStdGen rngSeed
126−
127−
128 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
118 deadline :: UTCTime <- addUTCTime (fromInteger $ maxRuntime * 1000000) <$> getCurrentTime
129− (stopreason, fs ) <- runStateT
119+ (stopreason, _fs) <-
120+ runStateT
130− (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get)) FuzzState{..}
121+ (untilDone (maxReps, deadline) go <* (evaluateCoverage =<< get))
122+ FuzzState {..}
131 print stopreason
123 print stopreason
132 pure Nothing
124 pure Nothing
133 where
125 where
134 -- something less terrible later
126 -- something less terrible later
135 formatException :: RoboservantException -> Report
127 formatException :: RoboservantException -> Report
136 formatException = Report . show
128 formatException = Report . show
137−
138− -- evaluateCoverage :: FuzzState -> m ()
129+ -- evaluateCoverage :: FuzzState -> m ()
139− evaluateCoverage f@FuzzState{..}
130+ evaluateCoverage f@FuzzState {..}
140 | hitRoutes / totalRoutes > coverageThreshold = do
131 | hitRoutes / totalRoutes > coverageThreshold = do
141− liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
132+ liftIO $ print ("passed coverage", hitRoutes, totalRoutes)
142− pure ()
133+ pure ()
143 | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
134 | otherwise = throw $ RoboservantException InsufficientCoverage Nothing routeCount f
135+ where
144− where hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
136+ hitRoutes = (fromIntegral . Set.size . Set.fromList $ map apiOffset path)
145− totalRoutes = (fromIntegral routeCount)
137+ totalRoutes = (fromIntegral routeCount)
146−
147−
148− untilDone :: MonadIO m => (Integer,UTCTime) -> m a -> m StopReason
138+ untilDone :: MonadIO m => (Integer, UTCTime) -> m a -> m StopReason
149− untilDone (0,_) _ = pure HitMaxIterations
139+ untilDone (0, _) _ = pure HitMaxIterations
150 untilDone (n, deadline) action = do
140 untilDone (n, deadline) action = do
151 now <- liftIO getCurrentTime
141 now <- liftIO getCurrentTime
152 if now > deadline
142 if now > deadline
153 then pure TimedOut
143 then pure TimedOut
154 else do
144 else do
155− action
145+ _ <- action
156− untilDone (n-1, deadline) action
146+ untilDone (n -1, deadline) action
157−
158 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
147 reifiedApi = toReifiedApi (flattenServer @api server) (Proxy @(Endpoints api))
159 routeCount = length reifiedApi
148 routeCount = length reifiedApi
160−
149+ elementOrFail ::
161− elementOrFail :: (MonadState FuzzState m, MonadIO m)
150+ (MonadState FuzzState m, MonadIO m) =>
151+ [a] ->
162− => [a] -> m a
152+ m a
163 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
153 elementOrFail [] = liftIO . throw . RoboservantException NoPossibleMoves Nothing routeCount =<< get
164 elementOrFail l = do
154 elementOrFail l = do
165 st <- get
155 st <- get
166− let (index,newGen) = randomR (0, length l - 1) (currentRng st)
156+ let (index, newGen) = randomR (0, length l - 1) (currentRng st)
167− modify' $ \st' -> st' { currentRng = newGen }
157+ modify' $ \st' -> st' {currentRng = newGen}
168 pure (l !! index)
158 pure (l !! index)
169−
159+ withOp ::
170− withOp :: (MonadState FuzzState m, MonadIO m)
160+ (MonadState FuzzState m, MonadIO m) =>
161+ ( forall as.
171− => (forall as. (V.RecordToList as, V.RMap as)
162+ (V.RecordToList as, V.RMap as) =>
172− => FuzzOp
163+ FuzzOp ->
173− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
164+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
174− -> V.Rec (TypedF V.Identity) as -> m r
165+ V.Rec (TypedF V.Identity) as ->
166+ m r
175− )
167+ ) ->
176− -> m r
168+ m r
177 withOp callback = do
169 withOp callback = do
178 -- choose a call to make, from the endpoints with fillable arguments.
170 -- choose a call to make, from the endpoints with fillable arguments.
179− (offset, EndpointOption{..}) <- elementOrFail . options =<< get
171+ (offset, EndpointOption {..}) <- elementOrFail . options =<< get
172+ r <-
180− r <- V.rtraverse
173+ V.rtraverse
181− (\(tr :*: StashValue svs) -> elementOrFail $
174+ ( \(tr :*: StashValue svs) ->
175+ elementOrFail $
176+ zipWith
182− zipWith (\i xy -> V.Const i :*: tr :*: xy)
177+ (\i xy -> V.Const i :*: tr :*: xy)
183− [0..]
178+ [0 ..]
184− (NEL.toList svs)
179+ (NEL.toList svs)
185− )
180+ )
186− eoArgs
181+ eoArgs
187− let pathSegment = FuzzOp offset $
182+ let pathSegment =
183+ FuzzOp offset $
188− recordToList'
184+ recordToList'
189− (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
185+ (\(V.Const index :*: tr :*: _) -> Provenance (R.SomeTypeRep tr) index)
186+ r
187+ argValues =
188+ V.rmap
189+ (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
190 r
190 r
191− argValues = V.rmap
192− (\(_ :*: tr :*: (_, x)) -> tr :*: V.Identity x)
193− r
194− modify' (\f -> f { path = path f <> [pathSegment] })
191+ modify' (\f -> f {path = path f <> [pathSegment]})
195 callback pathSegment eoCall argValues
192 callback pathSegment eoCall argValues
196 where
193 where
197 options :: FuzzState -> [(ApiOffset, EndpointOption)]
194 options :: FuzzState -> [(ApiOffset, EndpointOption)]
198− options FuzzState{..} =
195+ options FuzzState {..} =
199 mapMaybe
196 mapMaybe
200− ( \(offset, ReifiedEndpoint{..}) -> do
197+ ( \(offset, ReifiedEndpoint {..}) -> do
201− args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
198+ args <- V.rtraverse (\(tr :*: Argument bf) -> (tr :*:) <$> bf stash) reArguments
202− pure (offset, EndpointOption reEndpointFunc args)
199+ pure (offset, EndpointOption reEndpointFunc args)
203 )
200 )
204 reifiedApi
201 reifiedApi
205−
202+ execute ::
206− execute :: (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as)
203+ (MonadState FuzzState m, MonadIO m, V.RecordToList as, V.RMap as) =>
207− => FuzzOp
204+ FuzzOp ->
208− -> V.Curried as (IO (Either ServerError (NonEmpty Dynamic)))
205+ V.Curried as (IO (Either ServerError (NonEmpty Dynamic))) ->
209− -> V.Rec (TypedF V.Identity) as
206+ V.Rec (TypedF V.Identity) as ->
210− -> m ()
207+ m ()
211 execute fuzzop func args = do
208 execute fuzzop func args = do
212 liftIO $ print fuzzop
209 liftIO $ print fuzzop
213 st <- get
210 st <- get
211+ let showable =
212+ unlines $
214− let showable = unlines $ ("args":map show argTypes)
213+ ("args" : map show argTypes)
215− <> ["fuzzop"
214+ <> [ "fuzzop",
216− , show fuzzop
215+ show fuzzop,
217− -- ,"dyncall"
216+ -- ,"dyncall"
218− -- ,show (dynTypeRep dyncall)
217+ -- ,show (dynTypeRep dyncall)
219− ,"state"
218+ "state",
220− ,show st]
219+ show st
220+ ]
221 liftIO $ putStrLn showable
221 liftIO $ putStrLn showable
222 liftIO (V.runcurry' func argVals) >>= \case
222 liftIO (V.runcurry' func argVals) >>= \case
223 -- parameterise this
223 -- parameterise this
@@ -225,48 +225,56 @@ fuzz server Config{..} checker = handle (pure . Just . formatException) $ do
225 case errHTTPCode serverError of
225 case errHTTPCode serverError of
226 500 -> throw serverError
226 500 -> throw serverError
227 _ -> do
227 _ -> do
228− liftIO $ print ("ignoring non-500 error" , serverError)
228+ liftIO $ print ("ignoring non-500 error", serverError)
229 Right (dyn :: NEL.NonEmpty Dynamic) -> do
229 Right (dyn :: NEL.NonEmpty Dynamic) -> do
230 liftIO $ print ("storing", fmap dynTypeRep dyn)
230 liftIO $ print ("storing", fmap dynTypeRep dyn)
231+ modify'
231− modify' (\fs@FuzzState{..} ->
232+ ( \fs@FuzzState {..} ->
232− fs { stash = addToStash (NEL.toList dyn) stash } )
233+ fs {stash = addToStash (NEL.toList dyn) stash}
234+ )
233 where
235 where
234 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
236 argVals = V.rmap (\(_ :*: V.Identity x) -> V.Identity x) args
235 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
237 argTypes = recordToList' (\(tr :*: _) -> R.SomeTypeRep tr) args
236−
238+ go ::
237− go :: (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m)
239+ (MonadState FuzzState m, MonadIO m, MonadBaseControl IO m) =>
238− => m ()
240+ m ()
239 go = withOp $ \op func args -> do
241 go = withOp $ \op func args -> do
242+ catches
240− catches (execute op func args)
243+ (execute op func args)
241− [ Handler (\(e :: SomeAsyncException) -> throw e)
244+ [ Handler (\(e :: SomeAsyncException) -> throw e),
242− , Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
245+ Handler (\(e :: SomeException) -> throw . RoboservantException ServerCrashed (Just e) routeCount =<< get)
243 ]
246 ]
247+ catch
244− catch (liftIO checker)
248+ (liftIO checker)
245− (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
249+ (\(e :: SomeException) -> throw . RoboservantException CheckerFailed (Just e) routeCount =<< get)
246
250
247−addToStash :: [Dynamic]
251+addToStash ::
248− -> Stash
252+ [Dynamic] ->
253+ Stash ->
249− -> Stash
254+ Stash
250addToStash result stash =
255addToStash result stash =
256+ foldr
251− foldr (\(Dynamic tr x) (Stash dict) -> Stash $
257+ ( \(Dynamic tr x) (Stash dict) ->
258+ Stash $
252− DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0],x):|[])) dict
259+ DM.insertWith renumber tr (StashValue (([Provenance (R.SomeTypeRep tr) 0], x) :| [])) dict
253 )
260 )
254 stash
261 stash
255 result
262 result
256 where
263 where
264+ renumber ::
257− renumber :: StashValue a
265+ StashValue a ->
258− -> StashValue a
266+ StashValue a ->
259− -> StashValue a
267+ StashValue a
260 renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
268 renumber (StashValue singleDyn) (StashValue l) = StashValue $ case NEL.toList singleDyn of
261− [([Provenance tr _], dyn)] -> l
269+ [([Provenance tr _], dyn)] ->
270+ l
262− <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
271+ <> pure ([Provenance tr (length (NEL.last l) + 1)], dyn)
263 _ -> error "should be impossible"
272 _ -> error "should be impossible"
264
273
265−
266-- why isn't this in vinyl?
274-- why isn't this in vinyl?
267−recordToList'
275+recordToList' ::
268− :: (V.RecordToList as, V.RMap as)
276+ (V.RecordToList as, V.RMap as) =>
269− => (forall x. f x -> a)
277+ (forall x. f x -> a) ->
270− -> V.Rec f as
278+ V.Rec f as ->
271− -> [a]
279+ [a]
272recordToList' f = V.recordToList . V.rmap (V.Const . f)
280recordToList' f = V.recordToList . V.rmap (V.Const . f)
src/Roboservant/Types.hs+5
@@ -15,11 +15,16 @@
15
15
16module Roboservant.Types
16module Roboservant.Types
17 ( module Roboservant.Types.Breakdown
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
22
25
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+2−72
@@ -1,85 +1,25 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
1{-# LANGUAGE DefaultSignatures #-}
4−{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DerivingStrategies #-}
2{-# LANGUAGE DerivingStrategies #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9−{-# LANGUAGE LambdaCase #-}
10−{-# LANGUAGE MultiParamTypeClasses #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE TypeApplications #-}
16−{-# LANGUAGE TypeFamilies #-}
17−{-# LANGUAGE TypeOperators #-}
18−{-# LANGUAGE UndecidableInstances #-}
19
3
20module Roboservant.Types.Breakdown where
4module Roboservant.Types.Breakdown where
21
5
22import Data.Dynamic (Dynamic, fromDynamic, toDyn)
6import Data.Dynamic (Dynamic, fromDynamic, toDyn)
23−import Data.List.NonEmpty (NonEmpty(..))
7+import Data.List.NonEmpty (NonEmpty (..))
24import qualified Data.List.NonEmpty as NEL
8import qualified Data.List.NonEmpty as NEL
25−import qualified Data.Map.Strict as Map
26import Data.Maybe (fromMaybe)
9import Data.Maybe (fromMaybe)
27import Data.Typeable (Typeable)
10import Data.Typeable (Typeable)
28−import qualified Data.Dependent.Map as DM
29−import Data.Dependent.Map (DMap)
30−import qualified Type.Reflection as R
31−import Data.Dependent.Sum
32−import Data.Kind
33−
34−data Provenance
35− = Provenance R.SomeTypeRep Int
36− deriving (Show,Eq)
37−
38−newtype StashValue a = StashValue { getStashValue :: NonEmpty ([Provenance], a) }
39− deriving (Functor, Show)
40−
41−-- wrap in newtype to give a custom Show instance, since the normal
42−-- instance for DMap is not happy since StashValue needs Show a to show
43−newtype Stash = Stash { getStash :: DMap R.TypeRep StashValue }
44− deriving (Semigroup, Monoid)
45−
46−instance Show Stash where
47− showsPrec i (Stash x) = showsPrec i $
48− Map.fromList . map (\(tr :=> StashValue vs) -> (R.SomeTypeRep tr, fmap fst vs)) $ DM.toList x
49−
50−class Typeable x => BuildFrom (x :: Type) where
51− buildFrom :: Stash -> Maybe (StashValue x)
52− default buildFrom :: Stash -> Maybe (StashValue x)
53− buildFrom = DM.lookup R.typeRep . getStash
54−
55− -- (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
56−
57−
58−-- baseLookup :: TypeRep -> Stash -> Maybe (NonEmpty ([Provenance], Dynamic))
59−-- baseLookup tr mmm = -- Map.lookup (typeRep (Proxy @x)) mmm
60−-- Map.lookup tr mmm
61
11
62-- | only use this when we are using the internal typerep map.
12-- | only use this when we are using the internal typerep map.
63promisedDyn :: Typeable a => Dynamic -> a
13promisedDyn :: Typeable a => Dynamic -> a
64promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
14promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
65
15
66−instance BuildFrom Bool
67−
68−instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
69− buildFrom dict = Just options
70− where options :: StashValue (Maybe x)
71− options = StashValue $
72− ([],Nothing) :|
73− (maybe [] (NEL.toList . getStashValue . fmap Just) $ buildFrom @x dict
74− )
75−
76class Breakdown x where
16class Breakdown x where
77 breakdown :: x -> NonEmpty Dynamic
17 breakdown :: x -> NonEmpty Dynamic
78 default breakdown :: Typeable x => x -> NonEmpty Dynamic
18 default breakdown :: Typeable x => x -> NonEmpty Dynamic
79 breakdown = pure . toDyn
19 breakdown = pure . toDyn
80
20
81-- | Can't break it down any further -- stuck in your teeth, maybe.
21-- | Can't break it down any further -- stuck in your teeth, maybe.
82−newtype Chewy x = Chewy { unChew :: x }
22+newtype Chewy x = Chewy {unChew :: x}
83
23
84instance Breakdown () where
24instance Breakdown () where
85 breakdown = pure . toDyn
25 breakdown = pure . toDyn
@@ -87,18 +27,8 @@ instance Breakdown () where
87instance Breakdown Int where
27instance Breakdown Int where
88 breakdown = pure . toDyn
28 breakdown = pure . toDyn
89
29
90−
91instance Typeable x => Breakdown (Chewy x) where
30instance Typeable x => Breakdown (Chewy x) where
92 breakdown x = pure (toDyn x)
31 breakdown x = pure (toDyn x)
93
32
94−--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
95−
96−-- instance (Typeable x, Generic x) => Breakdown x where
97−-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
98−
99−
100instance (Typeable a, Breakdown a) => Breakdown [a] where
33instance (Typeable a, Breakdown a) => Breakdown [a] where
101 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
34 breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
102−
103−instance (BuildFrom a) => BuildFrom [a] -- where
104−-- breakdown x = toDyn x :| mconcat (map (NEL.toList . breakdown) x)
src/Roboservant/Types/ReifiedApi.hs+2
@@ -29,7 +29,9 @@ import Data.List.NonEmpty (NonEmpty)
29import Data.Typeable (Typeable)
29import Data.Typeable (Typeable)
30import GHC.Generics ((:*:)(..))
30import GHC.Generics ((:*:)(..))
31import GHC.TypeLits (Symbol)
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)