git.iko.soy/elk
on bfae985 help sign in
elk/src/Generate/JavaScript/Foreign.hs
241 lines 5.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Foreign (encode, decode) where
5import Prelude hiding (maybe)
6import qualified Data.List as List
7import qualified Data.Text as Text
8import Data.Text (Text)
10import qualified AST.Expression.Optimized as Opt
11import qualified AST.Literal as Literal
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Type as T
14import qualified AST.Variable as Var
15import qualified Generate.JavaScript.Builder as JS
16import qualified Generate.JavaScript.Helpers as JS (function, ref)
17import qualified Generate.JavaScript.Variable as Var
18import Generate.JavaScript.Helpers ((<|), (==>))
22-- ENCODE
25encode :: T.Canonical -> JS.Expr
26encode tipe =
27 JS.function ["v"] [ JS.Return (Just (encodeHelp tipe (JS.ref "v"))) ]
30encodeHelp :: T.Canonical -> JS.Expr -> JS.Expr
31encodeHelp tipe expr =
32 case tipe of
33 T.Aliased _ args t ->
34 encodeHelp (T.dealias args t) expr
36 T.Lambda _ _ ->
37 error "encodeHelp: function"
39 T.Var _ ->
40 error "encodeHelp: type variable"
42 T.Type name
43 | Var.isPrim "Float" name -> expr
44 | Var.isPrim "Int" name -> expr
45 | Var.isPrim "Bool" name -> expr
46 | Var.isPrim "String" name -> expr
47 | Var.isJson name -> expr
48 | Var.isTuple name -> JS.Null
49 | otherwise -> error "encodeHelp: bad type"
51 T.App (T.Type name) [arg]
52 | Var.isMaybe name -> fromMaybe arg expr
53 | Var.isList name -> fromList arg expr
54 | Var.isArray name -> fromArray arg expr
55 | otherwise -> error "encodeHelp: bad union type"
57 T.App (T.Type name) args
58 | Var.isTuple name -> fromTuple args expr
60 T.App _ _ ->
61 error "encodeHelp: bad union type"
63 T.Record _ (Just _) ->
64 error "encodeHelp: bad record"
66 T.Record fields Nothing ->
67 let
68 convert (k, t) =
69 k ==> encodeHelp t (JS.DotRef expr (JS.Id k))
70 in
71 JS.Object (map convert fields)
74fromMaybe :: T.Canonical -> JS.Expr -> JS.Expr
75fromMaybe tipe expr =
76 JS.If
77 (JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing"))
78 (JS.Null)
79 (encodeHelp tipe (JS.DotRef expr (JS.Id "_0")))
82fromList :: T.Canonical -> JS.Expr -> JS.Expr
83fromList tipe expr =
84 let
85 array =
86 Var.coreNative "List" "toArray" <| expr
87 in
88 JS.DotRef array (JS.Id "map") <| encode tipe
91fromArray :: T.Canonical -> JS.Expr -> JS.Expr
92fromArray tipe expr =
93 let
94 array =
95 Var.coreNative "Array" "toJSArray" <| expr
96 in
97 JS.DotRef array (JS.Id "map") <| encode tipe
100fromTuple :: [T.Canonical] -> JS.Expr -> JS.Expr
101fromTuple types expr =
102 let
103 convert subType n =
104 encodeHelp subType $ JS.DotRef expr (JS.Id (Text.pack ('_':show n)))
105 in
106 JS.Array (zipWith convert types [ 0 .. length types ])
110-- SUBSCRIPTIONS
113decode :: T.Canonical -> Opt.Expr
114decode tipe =
115 case tipe of
116 T.Lambda _ _ ->
117 error "functions should not be allowed through input ports"
119 T.Var _ ->
120 error "type variables should not be allowed through input ports"
122 T.Aliased _ args t ->
123 decode (T.dealias args t)
125 T.Type name
126 | Var.isPrim "Float" name -> to "float"
127 | Var.isPrim "Int" name -> to "int"
128 | Var.isPrim "Bool" name -> to "bool"
129 | Var.isPrim "String" name -> to "string"
130 | Var.isJson name -> to "value"
131 | Var.isTuple name -> toTuple0
132 | otherwise -> error "decode: bad type"
134 T.App (T.Type name) [arg]
135 | Var.isMaybe name -> toMaybe arg
136 | Var.isList name -> to "list" <== [decode arg]
137 | Var.isArray name -> to "array" <== [decode arg]
138 | otherwise -> error "decode: bad union type"
140 T.App (T.Type name) args
141 | Var.isTuple name -> toTuple args
143 T.App _ _ ->
144 error "decode: bad union type"
146 T.Record _ (Just _) ->
147 error "decode: bad record"
149 T.Record fields Nothing ->
150 toRecord fields
153-- DECODE HELPERS
156to :: Text -> Opt.Expr
157to name =
158 Opt.VarGlobal jsonDecode name
161jsonDecode :: ModuleName.Canonical
162jsonDecode =
163 ModuleName.inCore "Json.Decode"
166field :: Text -> Opt.Expr -> Opt.Expr
167field name decoder =
168 to "field" <== [ Opt.Literal (Literal.Str name), decoder ]
171index :: Int -> Opt.Expr -> Opt.Expr
172index i decoder =
173 to "index" <== [ Opt.Literal (Literal.IntNum i), decoder ]
176(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
177(<==) func args =
178 Opt.Call func args
182-- COMPLEX DECODE HELPERS
185toMaybe :: T.Canonical -> Opt.Expr
186toMaybe tipe =
187 let
188 maybe tag =
189 Opt.VarGlobal (ModuleName.inCore "Maybe") tag
190 in
191 to "oneOf" <==
192 [ Opt.List
193 [ to "null" <== [ maybe "Nothing" ]
194 , to "map" <== [ maybe "Just", decode tipe ]
195 ]
196 ]
199toTuple0 :: Opt.Expr
200toTuple0 =
201 to "null" <== [ Opt.Ctor "_Tuple0" [] ]
204toTuple :: [T.Canonical] -> Opt.Expr
205toTuple types =
206 let
207 size =
208 length types
210 pairs =
211 zipWith (,) [ 0 .. size - 1] types
213 toVar i =
214 Text.pack ('x' : show i)
216 makeTuple =
217 to "succeed" <==
218 [ Opt.Ctor
219 (Text.pack ("_Tuple" ++ show size))
220 (map (Opt.VarLocal . toVar . fst) pairs)
221 ]
223 andThen (i, tipe) decoder =
224 to "andThen" <== [ Opt.Function [toVar i] decoder, index i (decode tipe) ]
225 in
226 List.foldr andThen makeTuple pairs
229toRecord :: [(Text, T.Canonical)] -> Opt.Expr
230toRecord fields =
231 let
232 toFieldExpr (key, _) =
233 (key, Opt.VarLocal key)
235 finalDecoder =
236 to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]
238 andThen (key, tipe) decoder =
239 to "andThen" <== [ Opt.Function [key] decoder, field key (decode tipe) ]
240 in
241 List.foldr andThen finalDecoder fields