Skip to content

Commit 8dbb7c9

Browse files
bitonicbitonic
committed
Add support for TypeScript
1 parent 731fb54 commit 8dbb7c9

File tree

5 files changed

+382
-0
lines changed

5 files changed

+382
-0
lines changed

‎solga-typescript/LICENSE‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
Copyright (c) 2020 Francesco Mazzoli
2+
3+
Permission is hereby granted, free of charge, to any person obtaining
4+
a copy of this software and associated documentation files (the
5+
"Software"), to deal in the Software without restriction, including
6+
without limitation the rights to use, copy, modify, merge, publish,
7+
distribute, sublicense, and/or sell copies of the Software, and to
8+
permit persons to whom the Software is furnished to do so, subject to
9+
the following conditions:
10+
11+
The above copyright notice and this permission notice shall be included
12+
in all copies or substantial portions of the Software.
13+
14+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

‎solga-typescript/Setup.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎solga-typescript/solga-typescript.cabal‎

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
name: solga-typescript
2+
version: 0.1.0.0
3+
synopsis: TypeScript types generation for Solga
4+
description: TypeScript types generation for Solga
5+
license: MIT
6+
license-file: LICENSE
7+
author: Francesco Mazzoli
8+
maintainer: [email protected]
9+
copyright: Copyright (C) 2019 Francesco Mazzoli
10+
category: Web
11+
build-type: Simple
12+
homepage: https://github.com/chpatrick/solga
13+
bug-reports: https://github.com/chpatrick/solga/issues
14+
-- extra-source-files:
15+
cabal-version: >=1.10
16+
17+
library
18+
exposed-modules: Solga.TypeScript
19+
build-depends: base >= 4.8 && < 5,
20+
solga-core,
21+
aeson-typescript,
22+
aeson,
23+
text,
24+
unordered-containers,
25+
containers,
26+
dlist
27+
hs-source-dirs: src
28+
default-language: Haskell2010
29+
ghc-options: -Wall

‎solga-typescript/src/Solga/TypeScript.hs‎

Lines changed: 328 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,328 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE KindSignatures #-}
4+
{-# LANGUAGE StrictData #-}
5+
{-# LANGUAGE TypeApplications #-}
6+
{-# LANGUAGE MultiWayIf #-}
7+
{-# LANGUAGE TypeOperators #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE DataKinds #-}
10+
{-# LANGUAGE DefaultSignatures #-}
11+
{-# LANGUAGE FlexibleContexts #-}
12+
{-# LANGUAGE LambdaCase #-}
13+
{-# LANGUAGE RecordWildCards #-}
14+
module Solga.TypeScript
15+
( Info(..)
16+
, Paths(..)
17+
, TypeScriptRoute(..)
18+
, typeScript
19+
) where
20+
21+
import qualified Data.Aeson.TypeScript.TH as Aeson
22+
import qualified Data.Aeson.TypeScript.Recursive as Aeson
23+
import Data.Text (Text)
24+
import qualified Data.Text as T
25+
import qualified Data.HashMap.Strict as HMS
26+
import Solga.Core
27+
import Data.Maybe (isJust, fromMaybe)
28+
import GHC.TypeLits
29+
import Data.Proxy
30+
import GHC.Generics
31+
import qualified Data.DList as DL
32+
import Data.List (foldl')
33+
import Data.Monoid ((<>))
34+
import Control.Monad (guard)
35+
import qualified Data.Set as S
36+
37+
{-
38+
export class TypeScriptRoute {
39+
private http: { fetch(url: RequestInfo, init?: RequestInit): Promise<Response> };
40+
private baseUrl: string;
41+
42+
constructor(baseUrl?: string, http?: { fetch(url: RequestInfo, init?: RequestInit): Promise<Response> }) {
43+
this.http = http ? http : <any>window;
44+
this.baseUrl = baseUrl ? baseUrl : "";
45+
}
46+
}
47+
-}
48+
49+
{-
50+
data Foo a b = Foo { foo1 :: a, foo2 :: b }
51+
52+
deriveTypeScript (defaultOptions {fieldLabelModifier = drop 3, constructorTagModifier = map toLower}) ''Foo
53+
54+
data Bar = Bar (Foo Int Bool) Int
55+
56+
deriveTypeScript (defaultOptions {fieldLabelModifier = drop 3, constructorTagModifier = map toLower}) ''Bar
57+
-}
58+
59+
-- The strategy is to build a single TypeScript type to represent all the possible
60+
-- requests that we can do.
61+
62+
data Info = Info
63+
{ infoReqJSON :: Maybe T.Text
64+
, infoReqMultiPart :: Bool
65+
, infoRespJSON :: Maybe T.Text
66+
, infoRespRaw :: Bool
67+
, infoMethod :: Maybe T.Text
68+
} deriving (Eq, Show)
69+
70+
data Paths =
71+
PathsCapture (DL.DList Paths)
72+
| PathsMatch [Text] (DL.DList Paths) -- match any of these
73+
| PathsEnd Info
74+
| PathsNothing
75+
deriving (Eq, Show)
76+
77+
generateTypeScript :: forall a. (TypeScriptRoute a) => Proxy a -> Either String (DL.DList Paths, S.Set Aeson.TSType)
78+
generateTypeScript _ = typeScriptRoute (Proxy @a) Info
79+
{ infoReqJSON = Nothing
80+
, infoReqMultiPart = False
81+
, infoRespJSON = Nothing
82+
, infoRespRaw = False
83+
, infoMethod = Nothing
84+
}
85+
86+
class TypeScriptRoute a where
87+
typeScriptRoute :: Proxy a -> Info -> Either String (DL.DList Paths, S.Set Aeson.TSType)
88+
default typeScriptRoute :: (TypeScriptRoute (Rep a ())) => Proxy a -> Info -> Either String (DL.DList Paths, S.Set Aeson.TSType)
89+
typeScriptRoute _ = typeScriptRoute (Proxy @(Rep a ()))
90+
91+
instance TypeScriptRoute (Raw a) where
92+
typeScriptRoute _ _info = return mempty
93+
94+
instance (TypeScriptRoute a) => TypeScriptRoute (End a) where
95+
typeScriptRoute _ = typeScriptRoute (Proxy @a)
96+
97+
instance TypeScriptRoute (RawResponse a) where
98+
typeScriptRoute _ info = return (pure (PathsEnd info{infoRespRaw = True}), mempty)
99+
100+
instance (Aeson.TypeScript a) => TypeScriptRoute (JSON a) where
101+
typeScriptRoute _ info = return
102+
( pure (PathsEnd info{infoRespJSON = Just (T.pack (Aeson.getTypeScriptType (Proxy @a)))})
103+
, S.singleton (Aeson.TSType (Proxy @a))
104+
)
105+
106+
instance (KnownSymbol seg, TypeScriptRoute next) => TypeScriptRoute (Seg seg next) where
107+
typeScriptRoute _ info = do
108+
(paths, types) <- typeScriptRoute (Proxy @next) info
109+
return (pure (PathsMatch [T.pack (symbolVal (Proxy :: Proxy seg))] paths), types)
110+
111+
instance (TypeScriptRoute left, TypeScriptRoute right) => TypeScriptRoute (left :<|> right) where
112+
typeScriptRoute _ info = mappend <$> typeScriptRoute (Proxy @left) info <*> typeScriptRoute (Proxy @right) info
113+
114+
class SymbolList (a :: [Symbol]) where
115+
symbolList :: Proxy a -> [T.Text]
116+
117+
instance SymbolList '[] where
118+
symbolList _ = []
119+
120+
instance (KnownSymbol seg, SymbolList segs) => SymbolList (seg ': segs) where
121+
symbolList _ = T.pack (symbolVal (Proxy @seg)) : symbolList (Proxy @segs)
122+
123+
instance (SymbolList segs, TypeScriptRoute next) => TypeScriptRoute (OneOfSegs segs next) where
124+
typeScriptRoute _ info = do
125+
let segs = symbolList (Proxy @segs)
126+
(paths, types) <- typeScriptRoute (Proxy @next) info
127+
return (pure (PathsMatch segs paths), types)
128+
129+
instance (TypeScriptRoute next) => TypeScriptRoute (Capture a next) where
130+
typeScriptRoute _ info = do
131+
(paths, types) <- typeScriptRoute (Proxy @next) info
132+
return (pure (PathsCapture paths), types)
133+
134+
instance (TypeScriptRoute next, KnownSymbol method) => TypeScriptRoute (Method method next) where
135+
typeScriptRoute _ info = case infoMethod info of
136+
Nothing -> typeScriptRoute (Proxy @next) info{infoMethod = Just (T.pack (symbolVal (Proxy @method)))}
137+
Just{} -> Left "Method set multiple times!"
138+
139+
instance (TypeScriptRoute next) => TypeScriptRoute (ExtraHeaders next) where
140+
typeScriptRoute _ = typeScriptRoute (Proxy @next)
141+
142+
instance (TypeScriptRoute next) => TypeScriptRoute (NoCache next) where
143+
typeScriptRoute _ = typeScriptRoute (Proxy @next)
144+
145+
instance (TypeScriptRoute next, Aeson.TypeScript a) => TypeScriptRoute (ReqBodyJSON a next) where
146+
typeScriptRoute _ info = case infoReqJSON info of
147+
Just{} -> Left "Req body set multiple times!"
148+
Nothing -> do
149+
(paths, types) <- typeScriptRoute (Proxy @next) info{infoReqJSON = Just (T.pack (Aeson.getTypeScriptType (Proxy @a)))}
150+
return (paths, S.insert (Aeson.TSType (Proxy @a)) types)
151+
152+
instance (TypeScriptRoute next) => TypeScriptRoute (WithIO next) where
153+
typeScriptRoute _ = typeScriptRoute (Proxy @next)
154+
155+
instance (TypeScriptRoute next) => TypeScriptRoute (ReqBodyMultipart a next) where
156+
typeScriptRoute _ info = if infoReqMultiPart info
157+
then Left "Req body set multiple times!"
158+
else typeScriptRoute (Proxy @next) info{infoReqMultiPart = True}
159+
160+
instance (TypeScriptRoute next) => TypeScriptRoute (WithReferer next) where
161+
typeScriptRoute _ = typeScriptRoute (Proxy @next)
162+
163+
-- Generic
164+
-- --------------------------------------------------------------------
165+
166+
instance TypeScriptRoute r => TypeScriptRoute (K1 i r p) where
167+
typeScriptRoute _ = typeScriptRoute (Proxy @r)
168+
169+
instance TypeScriptRoute (f p) => TypeScriptRoute (M1 i c f p) where
170+
typeScriptRoute _ = typeScriptRoute (Proxy :: Proxy (f p))
171+
172+
instance (TypeScriptRoute (left p), TypeScriptRoute (right p)) => TypeScriptRoute ((left :*: right) p) where
173+
typeScriptRoute _ info = mappend <$> typeScriptRoute (Proxy @(left p)) info <*> typeScriptRoute (Proxy @(right p)) info
174+
175+
-- To hide from TypeScript
176+
-- --------------------------------------------------------------------
177+
178+
instance (TypeScriptRoute next) => TypeScriptRoute (Hidden next) where
179+
typeScriptRoute _ _ = return (pure PathsNothing, mempty)
180+
181+
-- Computing the typescript stuff
182+
-- --------------------------------------------------------------------
183+
184+
-- env.seg("blah").param("foo").send("json-body");
185+
186+
data TypeScriptReq
187+
= TSRMultipart
188+
| TSRJson T.Text
189+
| TSRNoBody
190+
191+
data TypeScriptSend = TypeScriptSend
192+
{ tssMethod :: T.Text
193+
, tssReq :: TypeScriptReq
194+
, tssResp :: T.Text
195+
}
196+
197+
data TypeScriptDict = TypeScriptDict
198+
{ tsdSegments :: HMS.HashMap T.Text TypeScriptDict
199+
, tsdCapture :: Maybe TypeScriptDict
200+
, tsdSend :: Maybe TypeScriptSend
201+
}
202+
203+
data TypeScriptSeg
204+
= TSSConst T.Text
205+
| TSSVar T.Text
206+
207+
typeScript :: (TypeScriptRoute a) => Proxy a -> T.Text -> T.Text
208+
typeScript p name = case generateTypeScript p of
209+
Left err -> error err
210+
Right (paths, types) -> let
211+
dict = go paths
212+
in T.unlines
213+
[ T.pack $ Aeson.formatTSDeclarations $ do
214+
Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types)
215+
Aeson.getTypeScriptDeclarations typ
216+
, ""
217+
, "interface Send {"
218+
, " send<A>(url: string, method: string): Promise<A>,"
219+
, " sendJson<A, B>(url: string, method: string, req: A): Promise<B>,"
220+
, " sendForm<A>(url: string, method: string, req: FormData): Promise<A>,"
221+
, "}"
222+
, "function " <> name <> "(baseUrl: string, send: Send): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }"
223+
]
224+
where
225+
emptyDict = TypeScriptDict{ tsdSegments = mempty, tsdCapture = Nothing, tsdSend = Nothing }
226+
227+
go paths = goFields emptyDict (DL.toList paths)
228+
229+
goFields dict = \case
230+
[] -> dict
231+
path : paths -> goFields (pathToField dict path) paths
232+
233+
dictNonEmpty dict = isJust (tsdSend dict) || isJust (tsdCapture dict) || HMS.size (tsdSegments dict) > 0
234+
235+
mergeDicts dict1 dict2 = TypeScriptDict
236+
{ tsdCapture = case (tsdCapture dict1, tsdCapture dict2) of
237+
(Nothing, Nothing) -> Nothing
238+
(Just x, Nothing) -> x <$ guard (dictNonEmpty x)
239+
(Nothing, Just x) -> x <$ guard (dictNonEmpty x)
240+
(Just x, Just y) -> let z = mergeDicts x y in z <$ guard (dictNonEmpty z)
241+
, tsdSegments = HMS.filter dictNonEmpty (HMS.unionWith mergeDicts (tsdSegments dict1) (tsdSegments dict2))
242+
, tsdSend = case (tsdSend dict1, tsdSend dict2) of
243+
(Nothing, Nothing) -> Nothing
244+
(Just x, Nothing) -> Just x
245+
(Nothing, Just x) -> Just x
246+
(Just{}, Just{}) -> error "Conflicting sends"
247+
}
248+
249+
pathToField dict0 = \case
250+
PathsCapture paths -> mergeDicts dict0 (emptyDict { tsdCapture = Just (go paths) })
251+
PathsEnd info -> if infoRespRaw info
252+
then dict0
253+
else let
254+
req = case (infoReqMultiPart info, infoReqJSON info) of
255+
(True, Nothing) -> TSRMultipart
256+
(False, Just j) -> TSRJson j
257+
(True, Just{}) -> error "Got both multipart and json req body"
258+
(False, Nothing) -> TSRNoBody
259+
in mergeDicts dict0 emptyDict{ tsdSend = Just TypeScriptSend{ tssMethod = fromMaybe "GET" (infoMethod info), tssReq = req, tssResp = fromMaybe "void" (infoRespJSON info) } }
260+
PathsMatch segs paths -> let
261+
pathsDict = go paths
262+
in foldl' (\dict seg -> mergeDicts dict emptyDict{ tsdSegments = HMS.singleton seg pathsDict }) dict0 segs
263+
PathsNothing -> dict0
264+
265+
renderDictType dict = T.concat $ concat
266+
[ ["{"]
267+
, case tsdSend dict of
268+
Nothing -> []
269+
Just TypeScriptSend{..} ->
270+
[ "\"send\": (" <>
271+
(case tssReq of
272+
TSRJson j -> "req: " <> j
273+
TSRMultipart -> "req: FormData"
274+
TSRNoBody -> "") <>
275+
") => Promise<" <> tssResp <> ">"
276+
]
277+
, case tsdCapture dict of
278+
Nothing -> []
279+
Just ty -> ["\"param\": (p: string) => " <> renderDictType ty <> ", "]
280+
, if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesTypes (tsdSegments dict)] else []
281+
, ["}"]
282+
]
283+
284+
renderRoutesTypes segs = T.concat $ concat
285+
[ ["{"]
286+
, do
287+
(seg, ty) <- HMS.toList segs
288+
return (T.pack (show seg) <> ": " <> renderDictType ty <> ", ")
289+
, ["}"]
290+
]
291+
292+
renderDictExpr sendVar baseUrlVar segs dict = T.concat $ concat
293+
[ ["{"]
294+
, case tsdSend dict of
295+
Nothing -> []
296+
Just TypeScriptSend{..} -> let
297+
segToExpr = \case
298+
TSSConst c -> T.pack (show c)
299+
TSSVar v -> v
300+
urlExpr = baseUrlVar <> " + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')"
301+
in
302+
[ "\"send\": (" <>
303+
(case tssReq of
304+
TSRJson j -> "req: " <> j
305+
TSRMultipart -> "req: FormData"
306+
TSRNoBody -> "") <>
307+
"): Promise<" <> tssResp <> "> => { return " <>
308+
(case tssReq of
309+
TSRJson{} -> sendVar <> ".sendJson(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)"
310+
TSRMultipart{} -> sendVar <> ".sendForm(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)"
311+
TSRNoBody{} -> sendVar <> ".send(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ")") <> "; },"
312+
]
313+
, case tsdCapture dict of
314+
Nothing -> []
315+
Just ty -> let
316+
v = "param" <> T.pack (show (length segs))
317+
in ["\"param\": (" <> v <> ": string): " <> renderDictType ty <> " => { return " <> renderDictExpr sendVar baseUrlVar (TSSVar v : segs) ty <> "; }, "]
318+
, if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesExprs sendVar baseUrlVar segs (tsdSegments dict)] else []
319+
, ["}"]
320+
]
321+
322+
renderRoutesExprs sendVar baseUrlVar segs newSegs = T.concat $ concat
323+
[ ["{"]
324+
, do
325+
(seg, ty) <- HMS.toList newSegs
326+
return (T.pack (show seg) <> ": " <> renderDictExpr sendVar baseUrlVar (TSSConst seg : segs) ty <> ", ")
327+
, ["}"]
328+
]

‎stack.yaml‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ packages:
1111
- 'solga-router'
1212
- 'solga-client'
1313
- 'solga-client-ghcjs'
14+
- 'solga-typescript'
1415

1516
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
1617
extra-deps:
@@ -19,6 +20,8 @@ extra-deps:
1920
- jsaddle-dom-0.9.4.0
2021
- jsaddle-0.9.7.0
2122
- ref-tf-0.4.0.2
23+
- git: https://github.com/bitonic/aeson-typescript.git
24+
commit: 9dd14a8172f3cd715b07a3d9ec8cd1e049020215
2225

2326
# Override default flag values for local packages and extra-deps
2427
flags: {}

0 commit comments

Comments
 (0)