@@ -0,0 +1,312 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Optimize.Port
4+ ( toEncoder
5+ , toDecoder
6+ )
7+ where
8+
9+
10+import Prelude hiding (maybe, null)
11+import Control.Monad (foldM, zipWithM)
12+import qualified Data.Text as Text
13+import Data.Text (Text)
14+
15+import qualified AST.Expression.Optimized as Opt
16+import qualified AST.Literal as Literal
17+import qualified AST.Module.Name as ModuleName
18+import qualified AST.Type as T
19+import qualified AST.Variable as Var
20+import qualified Optimize.DecisionTree as DT
21+import qualified Optimize.Environment as Env
22+
23+
24+
25+-- ENCODE
26+
27+
28+toEncoder :: T.Canonical -> Env.Optimizer Opt.Expr
29+toEncoder tipe =
30+ case tipe of
31+ T.Aliased _ args t ->
32+ toEncoder (T.dealias args t)
33+
34+ T.Lambda _ _ ->
35+ error "toEncoder: function"
36+
37+ T.Var _ ->
38+ error "toEncoder: type variable"
39+
40+ T.Type name
41+ | Var.isPrim "Float" name -> encode "float"
42+ | Var.isPrim "Int" name -> encode "int"
43+ | Var.isPrim "Bool" name -> encode "bool"
44+ | Var.isPrim "String" name -> encode "string"
45+ | Var.isJson name -> encode "string"
46+ | Var.isTuple name -> encode "null"
47+ | otherwise -> error "toEncoder: bad type"
48+
49+ T.App (T.Type name) [arg]
50+ | Var.isMaybe name -> encodeMaybe arg
51+ | Var.isList name -> encodeList arg
52+ | Var.isArray name -> encodeArray arg
53+ | otherwise -> error "toEncoder: bad union type"
54+
55+ T.App (T.Type name) args
56+ | Var.isTuple name -> encodeTuple args
57+
58+ T.App _ _ ->
59+ error "toEncoder: bad union type"
60+
61+ T.Record _ (Just _) ->
62+ error "toEncoder: bad record"
63+
64+ T.Record fields Nothing ->
65+ let
66+ convert (field, typ) =
67+ do encoder <- toEncoder typ
68+ return
69+ ( field
70+ , Opt.Call encoder [ Opt.Access (Opt.VarLocal "r") field ]
71+ )
72+ in
73+ do record <- traverse convert fields
74+ return $ Opt.Function ["r"] (Opt.Record record)
75+
76+
77+
78+-- ENCODE HELPERS
79+
80+
81+encodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
82+encodeMaybe tipe =
83+ do null <- encode "null"
84+ encoder <- toEncoder tipe
85+
86+ let nothing = Var.inCore "Maybe" "Nothing"
87+ let test = (DT.Empty, DT.Constructor nothing)
88+ let just = Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "m") 0 ]
89+ let leaf expr = Opt.Leaf (Opt.Inline expr)
90+
91+ return $ Opt.Function ["m"] $
92+ Opt.Case "m" (Opt.Chain [test] (leaf null) (leaf just)) []
93+
94+
95+encodeList :: T.Canonical -> Env.Optimizer Opt.Expr
96+encodeList tipe =
97+ do list <- encode "list"
98+ map_ <- core "List" "map"
99+ encoder <- toEncoder tipe
100+ return $
101+ Opt.Function ["xs"] $
102+ Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
103+
104+
105+encodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
106+encodeArray tipe =
107+ do array <- encode "array"
108+ map_ <- core "Array" "map"
109+ encoder <- toEncoder tipe
110+ return $
111+ Opt.Function ["xs"] $
112+ Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
113+
114+
115+encodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
116+encodeTuple tipes =
117+ let
118+ convert tipe index =
119+ do encoder <- toEncoder tipe
120+ return $
121+ Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "t") index ]
122+ in
123+ do list <- encode "list"
124+ entries <- zipWithM convert tipes [ 0 .. length tipes ]
125+ return $ Opt.Function ["t"] $ Opt.Call list entries
126+
127+
128+
129+-- DECODE
130+
131+
132+toDecoder :: T.Canonical -> Env.Optimizer Opt.Expr
133+toDecoder tipe =
134+ case tipe of
135+ T.Lambda _ _ ->
136+ error "functions should not be allowed through input ports"
137+
138+ T.Var _ ->
139+ error "type variables should not be allowed through input ports"
140+
141+ T.Aliased _ args t ->
142+ toDecoder (T.dealias args t)
143+
144+ T.Type name
145+ | Var.isPrim "Float" name -> decode "float"
146+ | Var.isPrim "Int" name -> decode "int"
147+ | Var.isPrim "Bool" name -> decode "bool"
148+ | Var.isPrim "String" name -> decode "string"
149+ | Var.isJson name -> decode "value"
150+ | Var.isTuple name -> decodeTuple0
151+ | otherwise -> error "toDecoder: bad type"
152+
153+ T.App (T.Type name) [arg]
154+ | Var.isMaybe name -> decodeMaybe arg
155+ | Var.isList name -> decodeList arg
156+ | Var.isArray name -> decodeArray arg
157+ | otherwise -> error "toDecoder: bad union type"
158+
159+ T.App (T.Type name) args
160+ | Var.isTuple name -> decodeTuple args
161+
162+ T.App _ _ ->
163+ error "toDecoder: bad union type"
164+
165+ T.Record _ (Just _) ->
166+ error "toDecoder: bad record"
167+
168+ T.Record fields Nothing ->
169+ decodeRecord fields
170+
171+
172+
173+-- DECODE MAYBE
174+
175+
176+decodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
177+decodeMaybe tipe =
178+ do let nothing = Var.Global (ModuleName.inCore "Maybe") "Nothing"
179+ let just = Var.Global (ModuleName.inCore "Maybe") "Just"
180+
181+ Env.register nothing
182+ Env.register just
183+
184+ oneOf <- decode "oneOf"
185+ null <- decode "null"
186+ map_ <- decode "map"
187+
188+ subDecoder <- toDecoder tipe
189+
190+ return $
191+ Opt.Call oneOf
192+ [ Opt.List
193+ [ Opt.Call null [ Opt.VarGlobal nothing ]
194+ , Opt.Call map_ [ Opt.VarGlobal just, subDecoder ]
195+ ]
196+ ]
197+
198+
199+-- DECODE LIST
200+
201+
202+decodeList :: T.Canonical -> Env.Optimizer Opt.Expr
203+decodeList tipe =
204+ do list <- decode "list"
205+ decoder <- toDecoder tipe
206+ return $ Opt.Call list [ decoder ]
207+
208+
209+
210+-- DECODE ARRAY
211+
212+
213+decodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
214+decodeArray tipe =
215+ do array <- decode "array"
216+ decoder <- toDecoder tipe
217+ return $ Opt.Call array [ decoder ]
218+
219+
220+
221+-- DECODE TUPLES
222+
223+
224+decodeTuple0 :: Env.Optimizer Opt.Expr
225+decodeTuple0 =
226+ do null <- decode "null"
227+ return (Opt.Call null [ Opt.Ctor "_Tuple0" [] ])
228+
229+
230+decodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
231+decodeTuple types =
232+ let
233+ size =
234+ length types
235+
236+ entries =
237+ zip [ 0 .. size - 1] types
238+
239+ tuple =
240+ Opt.Ctor
241+ (Text.pack ("_Tuple" ++ show size))
242+ (map (Opt.VarLocal . indexToName . fst) entries)
243+ in
244+ do succeed <- decode "succeed"
245+ foldM indexAndThen (Opt.Call succeed [tuple]) entries
246+
247+
248+indexToName :: Int -> Text
249+indexToName index =
250+ Text.pack ('x' : show index)
251+
252+
253+indexAndThen :: Opt.Expr -> (Int, T.Canonical) -> Env.Optimizer Opt.Expr
254+indexAndThen decoder (i, tipe) =
255+ do andThen <- decode "andThen"
256+ index <- decode "index"
257+ typeDecoder <- toDecoder tipe
258+ return $
259+ Opt.Call andThen
260+ [ Opt.Function [indexToName i] decoder
261+ , Opt.Call index [ Opt.Literal (Literal.IntNum i), typeDecoder ]
262+ ]
263+
264+
265+
266+-- DECODE RECORDS
267+
268+
269+decodeRecord :: [(Text, T.Canonical)] -> Env.Optimizer Opt.Expr
270+decodeRecord fields =
271+ let
272+ toFieldExpr (key, _) =
273+ (key, Opt.VarLocal key)
274+
275+ record =
276+ Opt.Record (map toFieldExpr fields)
277+ in
278+ do succeed <- decode "succeed"
279+ foldM fieldAndThen (Opt.Call succeed [record]) fields
280+
281+
282+fieldAndThen :: Opt.Expr -> (Text, T.Canonical) -> Env.Optimizer Opt.Expr
283+fieldAndThen decoder (key, tipe) =
284+ do andThen <- decode "andThen"
285+ field <- decode "field"
286+ typeDecoder <- toDecoder tipe
287+ return $
288+ Opt.Call andThen
289+ [ Opt.Function [key] decoder
290+ , Opt.Call field [ Opt.Literal (Literal.Str key), typeDecoder ]
291+ ]
292+
293+
294+
295+-- GLOBALS HELPERS
296+
297+
298+core :: Text -> Text -> Env.Optimizer Opt.Expr
299+core home name =
300+ do let var = Var.Global (ModuleName.inCore home) name
301+ Env.register var
302+ return (Opt.VarGlobal var)
303+
304+
305+encode :: Text -> Env.Optimizer Opt.Expr
306+encode name =
307+ core "Json.Encode" name
308+
309+
310+decode :: Text -> Env.Optimizer Opt.Expr
311+decode name =
312+ core "Json.Decode" name