git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Optimize/Port.hs
323 lines 7.8 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 (N.toText 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 encoder <- toEncoder tipe
96 return $ Opt.Call list [ encoder ]
99encodeArray :: Can.Type -> Names.Tracker Opt.Expr
100encodeArray tipe =
101 do array <- encode "array"
102 encoder <- toEncoder tipe
103 return $ Opt.Call array [ encoder ]
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 N.dollar))) body
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 arg1 <- encodeArg "a" a
118 arg2 <- encodeArg "b" b
120 Opt.Function [N.dollar] <$>
121 let_ "a" Index.first <$>
122 let_ "b" Index.second <$>
123 case maybeC of
124 Nothing ->
125 return $ Opt.Call list [ arg1, arg2 ]
127 Just c ->
128 do arg3 <- encodeArg "c" c
129 return $ let_ "c" Index.third $
130 Opt.Call list [ arg1, arg2, arg3 ]
134-- FLAGS DECODER
137toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr
138toFlagsDecoder tipe =
139 case tipe of
140 Can.TUnit ->
141 do succeed <- decode "succeed"
142 return $ Opt.Call succeed [ Opt.Unit ]
144 _ ->
145 toDecoder tipe
149-- DECODE
152toDecoder :: Can.Type -> Names.Tracker Opt.Expr
153toDecoder tipe =
154 case tipe of
155 Can.TLambda _ _ ->
156 error "functions should not be allowed through input ports"
158 Can.TVar _ ->
159 error "type variables should not be allowed through input ports"
161 Can.TAlias _ _ args alias ->
162 toDecoder (Type.dealias args alias)
164 Can.TUnit ->
165 decodeTuple0
167 Can.TTuple a b c ->
168 decodeTuple a b c
170 Can.TType _ name args ->
171 case args of
172 []
173 | name == N.float -> decode "float"
174 | name == N.int -> decode "int"
175 | name == N.bool -> decode "bool"
176 | name == N.string -> decode "string"
177 | name == N.value -> decode "value"
179 [arg]
180 | name == N.maybe -> decodeMaybe arg
181 | name == N.list -> decodeList arg
182 | name == N.array -> decodeArray arg
184 _ ->
185 error "toDecoder: bad type"
187 Can.TRecord _ (Just _) ->
188 error "toDecoder: bad record"
190 Can.TRecord fields Nothing ->
191 decodeRecord fields
195-- DECODE MAYBE
198decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
199decodeMaybe tipe =
200 do nothing <- Names.registerGlobal ModuleName.maybe "Nothing"
201 just <- Names.registerGlobal ModuleName.maybe "Just"
203 oneOf <- decode "oneOf"
204 null <- decode "null"
205 map_ <- decode "map"
207 subDecoder <- toDecoder tipe
209 return $
210 Opt.Call oneOf
211 [ Opt.List
212 [ Opt.Call null [ nothing ]
213 , Opt.Call map_ [ just, subDecoder ]
214 ]
215 ]
218-- DECODE LIST
221decodeList :: Can.Type -> Names.Tracker Opt.Expr
222decodeList tipe =
223 do list <- decode "list"
224 decoder <- toDecoder tipe
225 return $ Opt.Call list [ decoder ]
229-- DECODE ARRAY
232decodeArray :: Can.Type -> Names.Tracker Opt.Expr
233decodeArray tipe =
234 do array <- decode "array"
235 decoder <- toDecoder tipe
236 return $ Opt.Call array [ decoder ]
240-- DECODE TUPLES
243decodeTuple0 :: Names.Tracker Opt.Expr
244decodeTuple0 =
245 do null <- decode "null"
246 return (Opt.Call null [ Opt.Unit ])
249decodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
250decodeTuple a b maybeC =
251 do succeed <- decode "succeed"
252 case maybeC of
253 Nothing ->
254 let tuple = Opt.Tuple (toLocal 0) (toLocal 1) Nothing in
255 indexAndThen 0 a =<<
256 indexAndThen 1 b (Opt.Call succeed [tuple])
258 Just c ->
259 let tuple = Opt.Tuple (toLocal 0) (toLocal 1) (Just (toLocal 2)) in
260 indexAndThen 0 a =<<
261 indexAndThen 1 b =<<
262 indexAndThen 2 c (Opt.Call succeed [tuple])
265toLocal :: Int -> Opt.Expr
266toLocal index =
267 Opt.VarLocal (N.addIndex "x" index)
270indexAndThen :: Int -> Can.Type -> Opt.Expr -> Names.Tracker Opt.Expr
271indexAndThen i tipe decoder =
272 do andThen <- decode "andThen"
273 index <- decode "index"
274 typeDecoder <- toDecoder tipe
275 return $
276 Opt.Call andThen
277 [ Opt.Function [N.addIndex "x" i] decoder
278 , Opt.Call index [ Opt.Int i, typeDecoder ]
279 ]
283-- DECODE RECORDS
286decodeRecord :: Map.Map N.Name Can.Type -> Names.Tracker Opt.Expr
287decodeRecord fields =
288 let
289 toFieldExpr name _ =
290 Opt.VarLocal name
292 record =
293 Opt.Record (Map.mapWithKey toFieldExpr fields)
294 in
295 do succeed <- decode "succeed"
296 foldM fieldAndThen (Opt.Call succeed [record]) =<<
297 Names.registerFieldDict fields (Map.toList fields)
300fieldAndThen :: Opt.Expr -> (N.Name, Can.Type) -> Names.Tracker Opt.Expr
301fieldAndThen decoder (key, tipe) =
302 do andThen <- decode "andThen"
303 field <- decode "field"
304 typeDecoder <- toDecoder tipe
305 return $
306 Opt.Call andThen
307 [ Opt.Function [key] decoder
308 , Opt.Call field [ Opt.Str (N.toText key), typeDecoder ]
309 ]
313-- GLOBALS HELPERS
316encode :: N.Name -> Names.Tracker Opt.Expr
317encode name =
318 Names.registerGlobal ModuleName.jsonEncode name
321decode :: N.Name -> Names.Tracker Opt.Expr
322decode name =
323 Names.registerGlobal ModuleName.jsonDecode name