1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Port
4  ( toEncoder
5  , toFlagsDecoder
6  , toDecoder
7  )
8  where
9
10
11import Prelude hiding (maybe, null)
12import Control.Monad (foldM)
13import qualified Data.Map as Map
14import qualified Data.Name as Name
15
16import qualified AST.Canonical as Can
17import qualified AST.Optimized as Opt
18import qualified AST.Utils.Type as Type
19import qualified Data.Index as Index
20import qualified Elm.ModuleName as ModuleName
21import qualified Optimize.Names as Names
22
23
24
25-- ENCODE
26
27
28toEncoder :: Can.Type -> Names.Tracker Opt.Expr
29toEncoder tipe =
30  case tipe of
31    Can.TAlias _ _ args alias ->
32      toEncoder (Type.dealias args alias)
33
34    Can.TLambda _ _ ->
35      error "toEncoder: function"
36
37    Can.TVar _ ->
38      error "toEncoder: type variable"
39
40    Can.TUnit ->
41      Opt.Function [Name.dollar] <$> encode "null"
42
43    Can.TTuple a b c ->
44      encodeTuple a b c
45
46    Can.TType _ name args ->
47      case args of
48        []
49          | name == Name.float  -> encode "float"
50          | name == Name.int    -> encode "int"
51          | name == Name.bool   -> encode "bool"
52          | name == Name.string -> encode "string"
53          | name == Name.value  -> Names.registerGlobal ModuleName.basics Name.identity
54
55        [arg]
56          | name == Name.maybe -> encodeMaybe arg
57          | name == Name.list  -> encodeList arg
58          | name == Name.array -> encodeArray arg
59
60        _ ->
61          error "toEncoder: bad custom type"
62
63    Can.TRecord _ (Just _) ->
64      error "toEncoder: bad record"
65
66    Can.TRecord fields Nothing ->
67      let
68        encodeField (name, Can.FieldType _ fieldType) =
69          do  encoder <- toEncoder fieldType
70              let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name]
71              return $ Opt.Tuple (Opt.Str (Name.toElmString name)) value Nothing
72      in
73      do  object <- encode "object"
74          keyValuePairs <- traverse encodeField (Map.toList fields)
75          Names.registerFieldDict fields $
76            Opt.Function [Name.dollar] (Opt.Call object [Opt.List keyValuePairs])
77
78
79
80-- ENCODE HELPERS
81
82
83encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
84encodeMaybe tipe =
85  do  null <- encode "null"
86      encoder <- toEncoder tipe
87      destruct <- Names.registerGlobal ModuleName.maybe "destruct"
88      return $ Opt.Function [Name.dollar] $
89        Opt.Call destruct [ null, encoder, Opt.VarLocal Name.dollar ]
90
91
92encodeList :: Can.Type -> Names.Tracker Opt.Expr
93encodeList tipe =
94  do  list <- encode "list"
95      encoder <- toEncoder tipe
96      return $ Opt.Call list [ encoder ]
97
98
99encodeArray :: Can.Type -> Names.Tracker Opt.Expr
100encodeArray tipe =
101  do  array <- encode "array"
102      encoder <- toEncoder tipe
103      return $ Opt.Call array [ encoder ]
104
105
106encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
107encodeTuple a b maybeC =
108  let
109    let_ arg index body =
110      Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root Name.dollar))) body
111
112    encodeArg arg tipe =
113      do  encoder <- toEncoder tipe
114          return $ Opt.Call encoder [ Opt.VarLocal arg ]
115  in
116  do  list <- encode "list"
117      identity <- Names.registerGlobal ModuleName.basics Name.identity
118      arg1 <- encodeArg "a" a
119      arg2 <- encodeArg "b" b
120
121      case maybeC of
122        Nothing ->
123          return $ Opt.Function [Name.dollar] $
124            let_ "a" Index.first $
125            let_ "b" Index.second $
126              Opt.Call list [ identity, Opt.List [ arg1, arg2 ] ]
127
128        Just c ->
129          do  arg3 <- encodeArg "c" c
130              return $ Opt.Function [Name.dollar] $
131                let_ "a" Index.first $
132                let_ "b" Index.second $
133                let_ "c" Index.third $
134                  Opt.Call list [ identity, Opt.List [ arg1, arg2, arg3 ] ]
135
136
137
138-- FLAGS DECODER
139
140
141toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr
142toFlagsDecoder tipe =
143  case tipe of
144    Can.TUnit ->
145      do  succeed <- decode "succeed"
146          return $ Opt.Call succeed [ Opt.Unit ]
147
148    _ ->
149      toDecoder tipe
150
151
152
153-- DECODE
154
155
156toDecoder :: Can.Type -> Names.Tracker Opt.Expr
157toDecoder tipe =
158  case tipe of
159    Can.TLambda _ _ ->
160      error "functions should not be allowed through input ports"
161
162    Can.TVar _ ->
163      error "type variables should not be allowed through input ports"
164
165    Can.TAlias _ _ args alias ->
166      toDecoder (Type.dealias args alias)
167
168    Can.TUnit ->
169      decodeTuple0
170
171    Can.TTuple a b c ->
172      decodeTuple a b c
173
174    Can.TType _ name args ->
175      case args of
176        []
177          | name == Name.float  -> decode "float"
178          | name == Name.int    -> decode "int"
179          | name == Name.bool   -> decode "bool"
180          | name == Name.string -> decode "string"
181          | name == Name.value  -> decode "value"
182
183        [arg]
184          | name == Name.maybe -> decodeMaybe arg
185          | name == Name.list  -> decodeList arg
186          | name == Name.array -> decodeArray arg
187
188        _ ->
189          error "toDecoder: bad type"
190
191    Can.TRecord _ (Just _) ->
192      error "toDecoder: bad record"
193
194    Can.TRecord fields Nothing ->
195      decodeRecord fields
196
197
198
199-- DECODE MAYBE
200
201
202decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
203decodeMaybe tipe =
204  do  nothing <- Names.registerGlobal ModuleName.maybe "Nothing"
205      just    <- Names.registerGlobal ModuleName.maybe "Just"
206
207      oneOf <- decode "oneOf"
208      null  <- decode "null"
209      map_  <- decode "map"
210
211      subDecoder <- toDecoder tipe
212
213      return $
214        Opt.Call oneOf
215          [ Opt.List
216              [ Opt.Call null [ nothing ]
217              , Opt.Call map_ [ just, subDecoder ]
218              ]
219          ]
220
221
222-- DECODE LIST
223
224
225decodeList :: Can.Type -> Names.Tracker Opt.Expr
226decodeList tipe =
227  do  list <- decode "list"
228      decoder <- toDecoder tipe
229      return $ Opt.Call list [ decoder ]
230
231
232
233-- DECODE ARRAY
234
235
236decodeArray :: Can.Type -> Names.Tracker Opt.Expr
237decodeArray tipe =
238  do  array <- decode "array"
239      decoder <- toDecoder tipe
240      return $ Opt.Call array [ decoder ]
241
242
243
244-- DECODE TUPLES
245
246
247decodeTuple0 :: Names.Tracker Opt.Expr
248decodeTuple0 =
249  do  null <- decode "null"
250      return (Opt.Call null [ Opt.Unit ])
251
252
253decodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
254decodeTuple a b maybeC =
255  do  succeed <- decode "succeed"
256      case maybeC of
257        Nothing ->
258          let tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in
259          indexAndThen 0 a =<<
260            indexAndThen 1 b (Opt.Call succeed [tuple])
261
262        Just c ->
263          let tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in
264          indexAndThen 0 a =<<
265            indexAndThen 1 b =<<
266              indexAndThen 2 c (Opt.Call succeed [tuple])
267
268
269toLocal :: Int -> Opt.Expr
270toLocal index =
271  Opt.VarLocal (Name.fromVarIndex index)
272
273
274indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr
275indexAndThen i tipe decoder =
276  do  andThen <- decode "andThen"
277      index <- decode "index"
278      typeDecoder <- toDecoder tipe
279      return $
280        Opt.Call andThen
281          [ Opt.Function [Name.fromVarIndex i] decoder
282          , Opt.Call index [ Opt.Int i, typeDecoder ]
283          ]
284
285
286
287-- DECODE RECORDS
288
289
290decodeRecord :: Map.Map Name.Name Can.FieldType -> Names.Tracker Opt.Expr
291decodeRecord fields =
292  let
293    toFieldExpr name _ =
294      Opt.VarLocal name
295
296    record =
297      Opt.Record (Map.mapWithKey toFieldExpr fields)
298  in
299    do  succeed <- decode "succeed"
300        foldM fieldAndThen (Opt.Call succeed [record]) =<<
301          Names.registerFieldDict fields (Map.toList fields)
302
303
304fieldAndThen :: Opt.Expr -> (Name.Name, Can.FieldType) -> Names.Tracker Opt.Expr
305fieldAndThen decoder (key, Can.FieldType _ tipe) =
306  do  andThen <- decode "andThen"
307      field <- decode "field"
308      typeDecoder <- toDecoder tipe
309      return $
310        Opt.Call andThen
311          [ Opt.Function [key] decoder
312          , Opt.Call field [ Opt.Str (Name.toElmString key), typeDecoder ]
313          ]
314
315
316
317-- GLOBALS HELPERS
318
319
320encode :: Name.Name -> Names.Tracker Opt.Expr
321encode name =
322  Names.registerGlobal ModuleName.jsonEncode name
323
324
325decode :: Name.Name -> Names.Tracker Opt.Expr
326decode name =
327  Names.registerGlobal ModuleName.jsonDecode name
328