git.iko.soy/roboservant
on master help sign in
initial breakdown
6fcaa26Mark Wotton
src/Roboservant/Types/Breakdown.hs+14−9
compare with master
unifiedsplit
@@ -18,6 +18,7 @@
18module Roboservant.Types.Breakdown where
18module Roboservant.Types.Breakdown where
19
19
20import Data.Dynamic (Dynamic, dynTypeRep, fromDynamic, toDyn)
20import Data.Dynamic (Dynamic, dynTypeRep, fromDynamic, toDyn)
21+import Data.IORef (IORef)
21import Data.List.NonEmpty (NonEmpty)
22import Data.List.NonEmpty (NonEmpty)
22import qualified Data.List.NonEmpty as NEL
23import qualified Data.List.NonEmpty as NEL
23import qualified Data.Map.Strict as Map
24import qualified Data.Map.Strict as Map
@@ -25,25 +26,29 @@ import Data.Map.Strict (Map)
25import Data.Maybe (fromMaybe)
26import Data.Maybe (fromMaybe)
26import Data.Proxy (Proxy (..))
27import Data.Proxy (Proxy (..))
27import Data.Typeable (TypeRep, Typeable, typeRep)
28import Data.Typeable (TypeRep, Typeable, typeRep)
28−import Hedgehog (Gen)
29+import Hedgehog (Gen, Opaque, Var)
29import qualified Hedgehog.Gen as Gen
30import qualified Hedgehog.Gen as Gen
30
31
31−class Typeable x => BuildFrom x where
32+type Stash v = Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
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))
35
33
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+
36−instance BuildFrom x => BuildFrom (Maybe x) where
39+-- instance BuildFrom x => BuildFrom (Maybe x) where
37− buildFrom dict = Nothing : fmap Just (buildFrom dict)
40+-- buildFrom dict = Nothing : fmap Just (buildFrom dict)
38
41
39class Breakdown x where
42class Breakdown x where
40− breakdown :: x -> Map TypeRep (NonEmpty Dynamic)
43+ breakdown :: x -> NonEmpty Dynamic
41
44
42-- | Can't break it down any further -- stuck in your teeth, maybe.
45-- | Can't break it down any further -- stuck in your teeth, maybe.
43newtype Chewy x = Chewy x
46newtype Chewy x = Chewy x
44
47
45instance Typeable x => Breakdown (Chewy x) where
48instance Typeable x => Breakdown (Chewy x) where
49+ breakdown x = pure (toDyn x)
50+
46− breakdown x = let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
51+--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
47
52
48-- instance (Typeable x, Generic x) => Breakdown x where
53-- instance (Typeable x, Generic x) => Breakdown x where
49-- breakdown = Map.fromListWith (<>) . fmap ((dynTypeRep &&& (\x -> NEL.fromList [x])) . toDyn . Generics.to) . _ . Generics.from
54-- 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)
25import Servant
25import Servant
26import Servant.API.Modifiers(FoldRequired,FoldLenient)
26import Servant.API.Modifiers(FoldRequired,FoldLenient)
27import Roboservant.Types.FlattenServer
27import Roboservant.Types.FlattenServer
28+import Roboservant.Types.Breakdown
29+import Data.List.NonEmpty (NonEmpty)
28
30
29
31
30newtype ApiOffset = ApiOffset Int
32newtype ApiOffset = ApiOffset Int
31 deriving (Eq, Show)
33 deriving (Eq, Show)
32 deriving newtype (Enum, Num)
34 deriving newtype (Enum, Num)
33
35
34−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
36+type ReifiedEndpoint = ([TypeRep], NonEmpty Dynamic)
35
37
36type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
38type ReifiedApi = [(ApiOffset, ReifiedEndpoint)]
37
39
@@ -63,18 +65,20 @@ instance NormalizeFunction x => NormalizeFunction (r -> x) where
63 type Normal (r -> x) = r -> Normal x
65 type Normal (r -> x) = r -> Normal x
64 normalize = fmap normalize
66 normalize = fmap normalize
65
67
66−instance Typeable x => NormalizeFunction (Handler x) where
68+instance (Typeable x, Breakdown x) => NormalizeFunction (Handler x) where
67− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
69+ type Normal (Handler x) = IO (Either ServerError (NonEmpty Dynamic))
68 normalize handler = (runExceptT . runHandler') handler >>= \case
70 normalize handler = (runExceptT . runHandler') handler >>= \case
69 Left serverError -> pure (Left serverError)
71 Left serverError -> pure (Left serverError)
72+ Right x -> pure $ Right $ breakdown x
73+
70− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
74+-- pure (Right (typeRep (Proxy @x), toDyn x))
71
75
72instance
76instance
73− Typeable responseType =>
77+ (Typeable responseType, Breakdown responseType) =>
74 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
78 ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
75 where
79 where
76− toReifiedEndpoint endpoint _ =
80+ toReifiedEndpoint endpoint _ = id
77− ([], typeRep (Proxy @responseType), endpoint)
81+ ([], _ endpoint)
78
82
79instance
83instance
80 (ToReifiedEndpoint endpoint) =>
84 (ToReifiedEndpoint endpoint) =>