git.iko.soy/roboservant
on master help sign in
initial breakdown
commit6fcaa263abcc13d9e6218753b53546d4838b8421 authorMark Wotton <mwotton@gmail.com> dateTue 29 Sep 2020, 09:17 (6 years ago) parentda4b071
2 files changed+25−16
compare with master
unifiedsplit
src/Roboservant/Types/Breakdown.hs+14−9 src/Roboservant/Types/ReifiedApi.hs+11−7
src/Roboservant/Types/Breakdown.hs+14−9
@@ -18,6 +18,7 @@
1818module Roboservant.Types.Breakdown where
1919
2020import Data.Dynamic (Dynamic, dynTypeRep, fromDynamic, toDyn)
21+import Data.IORef (IORef)
2122import Data.List.NonEmpty (NonEmpty)
2223import qualified Data.List.NonEmpty as NEL
2324import qualified Data.Map.Strict as Map
@@ -25,25 +26,29 @@ import Data.Map.Strict (Map)
2526import Data.Maybe (fromMaybe)
2627import Data.Proxy (Proxy (..))
2728import Data.Typeable (TypeRep, Typeable, typeRep)
28−import Hedgehog (Gen)
29+import Hedgehog (Gen, Opaque, Var)
2930import qualified Hedgehog.Gen as Gen
3031
31−class Typeable x => BuildFrom x where
32− buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]
33− default buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]
34− buildFrom = maybe [] (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
32+type Stash v = Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
3533
36−instance BuildFrom x => BuildFrom (Maybe x) where
37− buildFrom dict = Nothing : fmap Just (buildFrom dict)
34+-- class Typeable x => BuildFrom x where
35+-- buildFrom :: Stash -> [x]
36+-- default buildFrom :: Map TypeRep (NonEmpty Dynamic) -> [x]
37+-- buildFrom = maybe [] (fmap promisedDyn . NEL.toList) . Map.lookup (typeRep (Proxy @x))
38+
39+-- instance BuildFrom x => BuildFrom (Maybe x) where
40+-- buildFrom dict = Nothing : fmap Just (buildFrom dict)
3841
3942class Breakdown x where
40− breakdown :: x -> Map TypeRep (NonEmpty Dynamic)
43+ breakdown :: x -> NonEmpty Dynamic
4144
4245-- | Can't break it down any further -- stuck in your teeth, maybe.
4346newtype Chewy x = Chewy x
4447
4548instance Typeable x => Breakdown (Chewy x) where
46− breakdown x = let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
49+ breakdown x = pure (toDyn x)
50+
51+--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
4752
4853-- instance (Typeable x, Generic x) => Breakdown x where
4954-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
src/Roboservant/Types/ReifiedApi.hs+11−7
@@ -25,13 +25,15 @@ import GHC.TypeLits (Symbol)
2525import Servant
2626import Servant.API.Modifiers(FoldRequired,FoldLenient)
2727import Roboservant.Types.FlattenServer
28+import Roboservant.Types.Breakdown
29+import Data.List.NonEmpty (NonEmpty)
2830
2931
3032newtype ApiOffset = ApiOffset Int
3133 deriving (Eq, Show)
3234 deriving newtype (Enum, Num)
3335
34−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
36+type ReifiedEndpoint = ([TypeRep], NonEmpty Dynamic)
3537
3638type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
3739
@@ -63,18 +65,20 @@ instance NormalizeFunction x => NormalizeFunction (r -> x) where
6365 type Normal (r -> x) = r -> Normal x
6466 normalize = fmap normalize
6567
66−instance Typeable x => NormalizeFunction (Handler x) where
67− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
68+instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
69+ type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
6870 normalize handler = (runExceptT . runHandler') handler >>= \case
6971 Left serverError -> pure (Left serverError)
70− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
72+ Right x -> pure $ Right $ breakdown x
73+
74+-- pure (Right (typeRep (Proxy @x), toDyn x))
7175
7276instance
73− Typeable responseType =>
77+ (Typeable responseType, Breakdown responseType) =>
7478 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
7579 where
76− toReifiedEndpoint endpoint _ =
77− ([], typeRep (Proxy @responseType), endpoint)
80+ toReifiedEndpoint endpoint _ = id
81+ ([], _ endpoint)
7882
7983instance
8084 (ToReifiedEndpoint endpoint) =>