@@ -2,7 +2,6 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE DerivingStrategies #-}
44{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
65{-# LANGUAGE GeneralizedNewtypeDeriving #-}
76{-# LANGUAGE LambdaCase #-}
87{-# LANGUAGE PolyKinds #-}
@@ -14,172 +13,34 @@
1413{-# LANGUAGE TypeOperators #-}
1514{-# LANGUAGE UndecidableInstances #-}
1615
17−module Roboservant.Types where
16+module Roboservant.Types
17+ ( module Roboservant.Types,
18+ FlattenServer (..),
19+ ToReifiedApi (..),
20+ ReifiedApi,
21+ ApiOffset (..),
22+ )
23+where
1824
19−import Control.Monad.Except (runExceptT)
20−import Data.Dynamic (Dynamic, toDyn)
21−import Data.Function ((&))
25+import Data.Dynamic (Dynamic)
2226import Data.IORef (IORef)
2327import Data.List.NonEmpty (NonEmpty)
2428import Data.Map.Strict (Map)
25−import Data.Typeable (TypeRep, Typeable, typeRep)
26−import GHC.TypeLits (Symbol)
27−import Hedgehog
28−import Servant
29−import Servant.API.Modifiers
29+import Data.Typeable (TypeRep)
30+import Hedgehog (HTraversable (..), Opaque, Symbolic, Var)
31+import Roboservant.Types.FlattenServer
32+import Roboservant.Types.ReifiedApi
3033
3134data State v
3235 = State
3336 { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
3437 }
3538
36−class FlattenServer api where
37− flattenServer :: Server api -> Bundled (Endpoints api)
38−
39−instance
40− ( Endpoints (endpoint :<|> api) ~ (endpoint ': Endpoints api),
41− Server (endpoint :<|> api) ~ (Server endpoint :<|> Server api),
42− FlattenServer api
43− ) =>
44− FlattenServer (endpoint :<|> api)
45− where
46− flattenServer (endpoint :<|> server) = endpoint `AnEndpoint` flattenServer @api server
47−
48−instance
49− ( HasServer (x :> api) '[],
50− Endpoints (x :> api) ~ '[x :> api]
51− ) =>
52− FlattenServer (x :> api)
53− where
54− flattenServer server = server `AnEndpoint` NoEndpoints
55−
56−instance
57− ( HasServer (Verb method statusCode contentTypes responseType) '[],
58− Endpoints (Verb method statusCode contentTypes responseType) ~ '[Verb method statusCode contentTypes responseType]
59− ) =>
60− FlattenServer (Verb method statusCode contentTypes responseType)
61− where
62− flattenServer server = server `AnEndpoint` NoEndpoints
63−
64−type ReifiedEndpoint = ([TypeRep], TypeRep, Dynamic)
65−
66−type ReifiedApi = [(ApiOffset, [TypeRep], TypeRep, Dynamic)]
67−
68−data Bundled endpoints where
69− AnEndpoint :: Server endpoint -> Bundled endpoints -> Bundled (endpoint ': endpoints)
70− NoEndpoints :: Bundled '[]
71−
72−class ToReifiedApi (endpoints :: [*]) where
73− toReifiedApi :: Bundled endpoints -> Proxy endpoints -> ReifiedApi
74−
75−class ToReifiedEndpoint (endpoint :: *) where
76− toReifiedEndpoint :: Dynamic -> Proxy endpoint -> ReifiedEndpoint
77−
78−instance ToReifiedApi '[] where
79− toReifiedApi NoEndpoints _ = []
80−
81−instance
82− (Typeable (Normal (ServerT endpoint Handler)), NormalizeFunction (ServerT endpoint Handler), ToReifiedEndpoint endpoint, ToReifiedApi endpoints, Typeable (ServerT endpoint Handler)) =>
83− ToReifiedApi (endpoint : endpoints)
84− where
85− toReifiedApi (endpoint `AnEndpoint` endpoints) _ =
86− withOffset (toReifiedEndpoint (toDyn (normalize endpoint)) (Proxy @endpoint))
87− : map
88− (\(n, x, y, z) -> (n + 1, x, y, z))
89− (toReifiedApi endpoints (Proxy @endpoints))
90− where
91− withOffset (x, y, z) = (0, x, y, z)
92−
93−class NormalizeFunction m where
94− type Normal m
95− normalize :: m -> Normal m
96−
97−instance NormalizeFunction x => NormalizeFunction (r -> x) where
98− type Normal (r -> x) = r -> Normal x
99− normalize = fmap normalize
100−
101−instance Typeable x => NormalizeFunction (Handler x) where
102− type Normal (Handler x) = IO (Either ServerError (TypeRep, Dynamic))
103− normalize handler = (runExceptT . runHandler') handler >>= \case
104− Left serverError -> pure (Left serverError)
105− Right x -> pure (Right (typeRep (Proxy @x), toDyn x))
106−
107−instance
108− Typeable responseType =>
109− ToReifiedEndpoint (Verb method statusCode contentTypes responseType)
110− where
111− toReifiedEndpoint endpoint _ =
112− ([], typeRep (Proxy @responseType), endpoint)
113−
114−instance
115− (ToReifiedEndpoint endpoint) =>
116− ToReifiedEndpoint ((x :: Symbol) :> endpoint)
117− where
118− toReifiedEndpoint endpoint _ =
119− toReifiedEndpoint endpoint (Proxy @endpoint)
120−
121−instance
122− (ToReifiedEndpoint endpoint) =>
123− ToReifiedEndpoint (Description s :> endpoint)
124− where
125− toReifiedEndpoint endpoint _ =
126− toReifiedEndpoint endpoint (Proxy @endpoint)
127−
128−instance
129− (ToReifiedEndpoint endpoint) =>
130− ToReifiedEndpoint (Summary s :> endpoint)
131− where
132− toReifiedEndpoint endpoint _ =
133− toReifiedEndpoint endpoint (Proxy @endpoint)
134−
135−instance
136− (Typeable requestType, ToReifiedEndpoint endpoint) =>
137− ToReifiedEndpoint (QueryFlag name :> endpoint)
138− where
139− toReifiedEndpoint endpoint _ =
140− toReifiedEndpoint endpoint (Proxy @endpoint)
141− & \(args, result, typeRepMap) -> (typeRep (Proxy @Bool) : args, result, typeRepMap)
142−
143−instance
144− (Typeable (If (FoldRequired mods) paramType (Maybe paramType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
145− ToReifiedEndpoint (QueryParam' mods name paramType :> endpoint)
146− where
147− toReifiedEndpoint endpoint _ =
148− toReifiedEndpoint endpoint (Proxy @endpoint)
149− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) paramType (Maybe paramType))) : args, result, typeRepMap)
150−
151−instance
152− (Typeable (If (FoldRequired mods) headerType (Maybe headerType)), ToReifiedEndpoint endpoint, SBoolI (FoldRequired mods)) =>
153− ToReifiedEndpoint (Header' mods headerName headerType :> endpoint)
154− where
155− toReifiedEndpoint endpoint _ =
156− toReifiedEndpoint endpoint (Proxy @endpoint)
157− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldRequired mods) headerType (Maybe headerType))) : args, result, typeRepMap)
158−
159−instance
160− (Typeable captureType, ToReifiedEndpoint endpoint) =>
161− ToReifiedEndpoint (Capture' mods name captureType :> endpoint)
162− where
163− toReifiedEndpoint endpoint _ =
164− toReifiedEndpoint endpoint (Proxy @endpoint)
165− & \(args, result, typeRepMap) -> (typeRep (Proxy @captureType) : args, result, typeRepMap)
166−
167−instance
168− (Typeable (If (FoldLenient mods) (Either String requestType) requestType), ToReifiedEndpoint endpoint, SBoolI (FoldLenient mods)) =>
169− ToReifiedEndpoint (ReqBody' mods contentTypes requestType :> endpoint)
170− where
171− toReifiedEndpoint endpoint _ =
172− toReifiedEndpoint endpoint (Proxy @endpoint)
173− & \(args, result, typeRepMap) -> (typeRep (Proxy @(If (FoldLenient mods) (Either String requestType) requestType)) : args, result, typeRepMap)
174−
175−newtype ApiOffset = ApiOffset Int
176− deriving (Eq, Show)
177− deriving newtype (Enum, Num)
178−
17939-- | we need to specify an offset because it's entirely possible to have two
18040-- functions with the same arguments that do different things.
181−data Op (v :: * -> *) = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
182− | Preload TypeRep (Var Dynamic v)
41+data Op (v :: * -> *)
42+ = Op ApiOffset [(TypeRep, Var (Opaque (IORef Dynamic)) v)]
43+ | Preload TypeRep (Var Dynamic v)
18344
18445deriving instance Show (Op Symbolic)
18546