git.iko.soy/elk
on e99688d help sign in
elk/src/Generate/JavaScript/Foreign.hs
240 lines 6.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Foreign (encode, decode) where
5import Prelude hiding (maybe)
6import Control.Monad (zipWithM)
7import qualified Data.List as List
8import qualified Data.Text as Text
9import Data.Text (Text)
11import qualified AST.Expression.Optimized as Opt
12import qualified AST.Literal as Literal
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Type as T
15import qualified AST.Variable as Var
16import qualified Generate.JavaScript.Builder as JS
17import qualified Generate.JavaScript.Helpers as JS (function, ref)
18import Generate.JavaScript.Helpers ((<|), (==>))
19import qualified Generate.JavaScript.Variable as JS (Generator, global)
23-- ENCODE
26encode :: T.Canonical -> JS.Generator JS.Expr
27encode tipe =
28 do js <- encodeHelp tipe (JS.ref "v")
29 return $ JS.function ["v"] [ JS.Return (Just js) ]
32encodeHelp :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr
33encodeHelp tipe expr =
34 case tipe of
35 T.Aliased _ args t ->
36 encodeHelp (T.dealias args t) expr
38 T.Lambda _ _ ->
39 error "encodeHelp: function"
41 T.Var _ ->
42 error "encodeHelp: type variable"
44 T.Type name
45 | Var.isPrim "Float" name -> pure expr
46 | Var.isPrim "Int" name -> pure expr
47 | Var.isPrim "Bool" name -> pure expr
48 | Var.isPrim "String" name -> pure expr
49 | Var.isJson name -> pure expr
50 | Var.isTuple name -> pure JS.Null
51 | otherwise -> error "encodeHelp: bad type"
53 T.App (T.Type name) [arg]
54 | Var.isMaybe name -> fromMaybe arg expr
55 | Var.isList name -> fromList arg expr
56 | Var.isArray name -> fromArray arg expr
57 | otherwise -> error "encodeHelp: bad union type"
59 T.App (T.Type name) args
60 | Var.isTuple name -> fromTuple args expr
62 T.App _ _ ->
63 error "encodeHelp: bad union type"
65 T.Record _ (Just _) ->
66 error "encodeHelp: bad record"
68 T.Record fields Nothing ->
69 let
70 convert (k, t) =
71 (==>) k <$> encodeHelp t (JS.DotRef expr (JS.Id k))
72 in
73 JS.Object <$> traverse convert fields
76fromMaybe :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr
77fromMaybe tipe expr =
78 do js <- encodeHelp tipe (JS.DotRef expr (JS.Id "_0"))
79 let isNothing = JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing")
80 return $ JS.If isNothing JS.Null js
83fromList :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr
84fromList tipe expr =
85 do let var = Var.Global (ModuleName.inCore "Elm.Kernel.List") "toArray"
86 toArray <- JS.global var
87 encoder <- encode tipe
88 return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder
91fromArray :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr
92fromArray tipe expr =
93 do let var = Var.Global (ModuleName.inCore "Elm.Kernel.Array") "toJSArray"
94 toArray <- JS.global var
95 encoder <- encode tipe
96 return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder
99fromTuple :: [T.Canonical] -> JS.Expr -> JS.Generator JS.Expr
100fromTuple types expr =
101 let
102 convert subType n =
103 encodeHelp subType $ JS.DotRef expr (JS.Id (Text.pack ('_':show n)))
104 in
105 JS.Array <$> zipWithM convert types [ 0 .. length types ]
109-- SUBSCRIPTIONS
112decode :: T.Canonical -> Opt.Expr
113decode tipe =
114 case tipe of
115 T.Lambda _ _ ->
116 error "functions should not be allowed through input ports"
118 T.Var _ ->
119 error "type variables should not be allowed through input ports"
121 T.Aliased _ args t ->
122 decode (T.dealias args t)
124 T.Type name
125 | Var.isPrim "Float" name -> to "float"
126 | Var.isPrim "Int" name -> to "int"
127 | Var.isPrim "Bool" name -> to "bool"
128 | Var.isPrim "String" name -> to "string"
129 | Var.isJson name -> to "value"
130 | Var.isTuple name -> toTuple0
131 | otherwise -> error "decode: bad type"
133 T.App (T.Type name) [arg]
134 | Var.isMaybe name -> toMaybe arg
135 | Var.isList name -> to "list" <== [decode arg]
136 | Var.isArray name -> to "array" <== [decode arg]
137 | otherwise -> error "decode: bad union type"
139 T.App (T.Type name) args
140 | Var.isTuple name -> toTuple args
142 T.App _ _ ->
143 error "decode: bad union type"
145 T.Record _ (Just _) ->
146 error "decode: bad record"
148 T.Record fields Nothing ->
149 toRecord fields
152-- DECODE HELPERS
155to :: Text -> Opt.Expr
156to name =
157 Opt.VarGlobal (Var.Global jsonDecode name)
160jsonDecode :: ModuleName.Canonical
161jsonDecode =
162 ModuleName.inCore "Json.Decode"
165field :: Text -> Opt.Expr -> Opt.Expr
166field name decoder =
167 to "field" <== [ Opt.Literal (Literal.Str name), decoder ]
170index :: Int -> Opt.Expr -> Opt.Expr
171index i decoder =
172 to "index" <== [ Opt.Literal (Literal.IntNum i), decoder ]
175(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
176(<==) func args =
177 Opt.Call func args
181-- COMPLEX DECODE HELPERS
184toMaybe :: T.Canonical -> Opt.Expr
185toMaybe tipe =
186 let
187 maybe tag =
188 Opt.VarGlobal (Var.Global (ModuleName.inCore "Maybe") tag)
189 in
190 to "oneOf" <==
191 [ Opt.List
192 [ to "null" <== [ maybe "Nothing" ]
193 , to "map" <== [ maybe "Just", decode tipe ]
194 ]
195 ]
198toTuple0 :: Opt.Expr
199toTuple0 =
200 to "null" <== [ Opt.Ctor "_Tuple0" [] ]
203toTuple :: [T.Canonical] -> Opt.Expr
204toTuple types =
205 let
206 size =
207 length types
209 pairs =
210 zipWith (,) [ 0 .. size - 1] types
212 toVar i =
213 Text.pack ('x' : show i)
215 makeTuple =
216 to "succeed" <==
217 [ Opt.Ctor
218 (Text.pack ("_Tuple" ++ show size))
219 (map (Opt.VarLocal . toVar . fst) pairs)
220 ]
222 andThen (i, tipe) decoder =
223 to "andThen" <== [ Opt.Function [toVar i] decoder, index i (decode tipe) ]
224 in
225 List.foldr andThen makeTuple pairs
228toRecord :: [(Text, T.Canonical)] -> Opt.Expr
229toRecord fields =
230 let
231 toFieldExpr (key, _) =
232 (key, Opt.VarLocal key)
234 finalDecoder =
235 to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]
237 andThen (key, tipe) decoder =
238 to "andThen" <== [ Opt.Function [key] decoder, field key (decode tipe) ]
239 in
240 List.foldr andThen finalDecoder fields