@@ -2,188 +2,25 @@
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE DerivingStrategies #-}
44{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE LambdaCase #-}
85{-# LANGUAGE PolyKinds #-}
96{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeApplications #-}
137{-# LANGUAGE TypeFamilies #-}
14−{-# LANGUAGE TypeOperators #-}
158{-# LANGUAGE UndecidableInstances #-}
169
17−module Roboservant.Types where
18−
19−import Control.Monad.Except (runExceptT)
20−import Data.Dynamic (Dynamic, toDyn)
21−import Data.Function ((&))
22−import Data.IORef (IORef)
23−import Data.List.NonEmpty (NonEmpty)
24−import 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
30−
31−data State v
32− = State
33− { stateRefs :: Map TypeRep (NonEmpty (Var (Opaque (IORef Dynamic)) v))
34− }
35−
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−
179−-- | we need to specify an offset because it's entirely possible to have two
180−-- 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)
183−
184−deriving instance Show (Op Symbolic)
185−
186−instance HTraversable Op where
187− htraverse r = \case
188− Op offset args -> Op offset <$> traverse (\(t, v) -> (t,) <$> htraverse r v) args
189− Preload tr v -> Preload tr <$> htraverse r v
10+module Roboservant.Types
11+ ( module Roboservant.Types.Breakdown,
12+ module Roboservant.Types.BuildFrom,
13+ module Roboservant.Types.ReifiedApi,
14+ module Roboservant.Types.ReifiedApi.Server,
15+ module Roboservant.Types.Internal,
16+ module Roboservant.Types.Config,
17+ )
18+where
19+
20+import Roboservant.Types.Breakdown
21+import Roboservant.Types.BuildFrom
22+import Roboservant.Types.Config
23+import Roboservant.Types.Internal
24+import Roboservant.Types.ReifiedApi
25+import Roboservant.Types.ReifiedApi.Server
26+import Roboservant.Types.Orphans()