git.iko.soy/elk
on 00a3069 help sign in
elk/src/Optimize/Port.hs
329 lines 8.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Port
4 ( toEncoder
5 , toFlagsDecoder
6 , toDecoder
7 )
8 where
11import Prelude hiding (maybe, null)
12import Control.Monad (foldM)
13import qualified Data.Map as Map
15import qualified AST.Canonical as Can
16import qualified AST.Optimized as Opt
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Utils.Type as Type
19import qualified Data.Index as Index
20import qualified Elm.Name as N
21import qualified Optimize.Names as Names
25-- ENCODE
28toEncoder :: Can.Type -> Names.Tracker Opt.Expr
29toEncoder tipe =
30 case tipe of
31 Can.TAlias _ _ args alias ->
32 toEncoder (Type.dealias args alias)
34 Can.TLambda _ _ ->
35 error "toEncoder: function"
37 Can.TVar _ ->
38 error "toEncoder: type variable"
40 Can.TUnit ->
41 encode "null"
43 Can.TTuple a b c ->
44 encodeTuple a b c
46 Can.TType _ name args ->
47 case args of
48 []
49 | name == N.float -> encode "float"
50 | name == N.int -> encode "int"
51 | name == N.bool -> encode "bool"
52 | name == N.string -> encode "string"
53 | name == N.value -> encode "value"
55 [arg]
56 | name == N.maybe -> encodeMaybe arg
57 | name == N.list -> encodeList arg
58 | name == N.array -> encodeArray arg
60 _ ->
61 error "toEncoder: bad union type"
63 Can.TRecord _ (Just _) ->
64 error "toEncoder: bad record"
66 Can.TRecord fields Nothing ->
67 let
68 encodeField (name, fieldType) =
69 do encoder <- toEncoder fieldType
70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal N.dollar) name]
71 return $ Opt.Tuple (Opt.Str name) value Nothing
72 in
73 do object <- encode "object"
74 keyValuePairs <- traverse encodeField (Map.toList fields)
75 Names.registerFieldDict fields $
76 Opt.Function [N.dollar] (Opt.Call object [Opt.List keyValuePairs])
80-- ENCODE HELPERS
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 [N.dollar] $
89 Opt.Call destruct [ null, encoder, Opt.VarLocal N.dollar ]
92encodeList :: Can.Type -> Names.Tracker Opt.Expr
93encodeList tipe =
94 do list <- encode "list"
95 map_ <- Names.registerGlobal ModuleName.list "map"
96 encoder <- toEncoder tipe
97 return $
98 Opt.Function [N.dollar] $
99 Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal N.dollar ] ]
102encodeArray :: Can.Type -> Names.Tracker Opt.Expr
103encodeArray tipe =
104 do array <- encode "array"
105 map_ <- Names.registerGlobal ModuleName.array "map"
106 encoder <- toEncoder tipe
107 return $
108 Opt.Function [N.dollar] $
109 Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal N.dollar ] ]
112encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
113encodeTuple a b maybeC =
114 let
115 let_ arg index body =
116 Opt.Destruct (Opt.Destructor arg (Opt.Index index (Opt.Root N.dollar))) body
118 encodeArg arg tipe =
119 do encoder <- toEncoder tipe
120 return $ Opt.Call encoder [ Opt.VarLocal arg ]
121 in
122 do list <- encode "list"
123 arg1 <- encodeArg "a" a
124 arg2 <- encodeArg "b" b
126 Opt.Function [N.dollar] <$>
127 let_ "a" Index.first <$>
128 let_ "b" Index.second <$>
129 case maybeC of
130 Nothing ->
131 return $ Opt.Call list [ arg1, arg2 ]
133 Just c ->
134 do arg3 <- encodeArg "c" c
135 return $ let_ "c" Index.third $
136 Opt.Call list [ arg1, arg2, arg3 ]
140-- FLAGS DECODER
143toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr
144toFlagsDecoder tipe =
145 case tipe of
146 Can.TUnit ->
147 do succeed <- decode "succeed"
148 return $ Opt.Call succeed [ Opt.Unit ]
150 _ ->
151 toDecoder tipe
155-- DECODE
158toDecoder :: Can.Type -> Names.Tracker Opt.Expr
159toDecoder tipe =
160 case tipe of
161 Can.TLambda _ _ ->
162 error "functions should not be allowed through input ports"
164 Can.TVar _ ->
165 error "type variables should not be allowed through input ports"
167 Can.TAlias _ _ args alias ->
168 toDecoder (Type.dealias args alias)
170 Can.TUnit ->
171 decodeTuple0
173 Can.TTuple a b c ->
174 decodeTuple a b c
176 Can.TType _ name args ->
177 case args of
178 []
179 | name == N.float -> decode "float"
180 | name == N.int -> decode "int"
181 | name == N.bool -> decode "bool"
182 | name == N.string -> decode "string"
183 | name == N.value -> decode "value"
185 [arg]
186 | name == N.maybe -> decodeMaybe arg
187 | name == N.list -> decodeList arg
188 | name == N.array -> decodeArray arg
190 _ ->
191 error "toDecoder: bad type"
193 Can.TRecord _ (Just _) ->
194 error "toDecoder: bad record"
196 Can.TRecord fields Nothing ->
197 decodeRecord fields
201-- DECODE MAYBE
204decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
205decodeMaybe tipe =
206 do nothing <- Names.registerGlobal ModuleName.maybe "Nothing"
207 just <- Names.registerGlobal ModuleName.maybe "Just"
209 oneOf <- decode "oneOf"
210 null <- decode "null"
211 map_ <- decode "map"
213 subDecoder <- toDecoder tipe
215 return $
216 Opt.Call oneOf
217 [ Opt.List
218 [ Opt.Call null [ nothing ]
219 , Opt.Call map_ [ just, subDecoder ]
220 ]
221 ]
224-- DECODE LIST
227decodeList :: Can.Type -> Names.Tracker Opt.Expr
228decodeList tipe =
229 do list <- decode "list"
230 decoder <- toDecoder tipe
231 return $ Opt.Call list [ decoder ]
235-- DECODE ARRAY
238decodeArray :: Can.Type -> Names.Tracker Opt.Expr
239decodeArray tipe =
240 do array <- decode "array"
241 decoder <- toDecoder tipe
242 return $ Opt.Call array [ decoder ]
246-- DECODE TUPLES
249decodeTuple0 :: Names.Tracker Opt.Expr
250decodeTuple0 =
251 do null <- decode "null"
252 return (Opt.Call null [ Opt.Unit ])
255decodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
256decodeTuple a b maybeC =
257 do succeed <- decode "succeed"
258 case maybeC of
259 Nothing ->
260 let tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in
261 indexAndThen 0 a =<<
262 indexAndThen 1 b (Opt.Call succeed [tuple])
264 Just c ->
265 let tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in
266 indexAndThen 0 a =<<
267 indexAndThen 1 b =<<
268 indexAndThen 2 c (Opt.Call succeed [tuple])
271toLocal :: Int -> Opt.Expr
272toLocal index =
273 Opt.VarLocal (N.addIndex "x" index)
276indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr
277indexAndThen i tipe decoder =
278 do andThen <- decode "andThen"
279 index <- decode "index"
280 typeDecoder <- toDecoder tipe
281 return $
282 Opt.Call andThen
283 [ Opt.Function [N.addIndex "x" i] decoder
284 , Opt.Call index [ Opt.Int i, typeDecoder ]
285 ]
289-- DECODE RECORDS
292decodeRecord :: Map.Map N.Name Can.Type -> Names.Tracker Opt.Expr
293decodeRecord fields =
294 let
295 toFieldExpr name _ =
296 Opt.VarLocal name
298 record =
299 Opt.Record (Map.mapWithKey toFieldExpr fields)
300 in
301 do succeed <- decode "succeed"
302 foldM fieldAndThen (Opt.Call succeed [record]) =<<
303 Names.registerFieldDict fields (Map.toList fields)
306fieldAndThen :: Opt.Expr -> (N.Name, Can.Type) -> Names.Tracker Opt.Expr
307fieldAndThen decoder (key, tipe) =
308 do andThen <- decode "andThen"
309 field <- decode "field"
310 typeDecoder <- toDecoder tipe
311 return $
312 Opt.Call andThen
313 [ Opt.Function [key] decoder
314 , Opt.Call field [ Opt.Str key, typeDecoder ]
315 ]
319-- GLOBALS HELPERS
322encode :: N.Name -> Names.Tracker Opt.Expr
323encode name =
324 Names.registerGlobal ModuleName.jsonEncode name
327decode :: N.Name -> Names.Tracker Opt.Expr
328decode name =
329 Names.registerGlobal ModuleName.jsonDecode name