git.iko.soy/elk
on 4624721 help sign in
elk/src/Optimize/Port.hs
327 lines 8.0 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.DecisionTree as DT
22import qualified Optimize.Names as Names
26-- ENCODE
29toEncoder :: Can.Type -> Names.Tracker Opt.Expr
30toEncoder tipe =
31 case tipe of
32 Can.TAlias _ _ args alias ->
33 toEncoder (Type.dealias args alias)
35 Can.TLambda _ _ ->
36 error "toEncoder: function"
38 Can.TVar _ ->
39 error "toEncoder: type variable"
41 Can.TUnit ->
42 encode "null"
44 Can.TTuple a b c ->
45 encodeTuple a b c
47 Can.TType _ name args ->
48 case args of
49 []
50 | name == N.float -> encode "float"
51 | name == N.int -> encode "int"
52 | name == N.bool -> encode "bool"
53 | name == N.string -> encode "string"
54 | name == N.value -> encode "value"
56 [arg]
57 | name == N.maybe -> encodeMaybe arg
58 | name == N.list -> encodeList arg
59 | name == N.array -> encodeArray arg
61 _ ->
62 error "toEncoder: bad union type"
64 Can.TRecord _ (Just _) ->
65 error "toEncoder: bad record"
67 Can.TRecord fields Nothing ->
68 let
69 encodeField (name, fieldType) =
70 do encoder <- toEncoder fieldType
71 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal N.dollar) name]
72 return $ Opt.Tuple (Opt.Str name) value Nothing
73 in
74 do object <- encode "object"
75 keyValuePairs <- traverse encodeField (Map.toList fields)
76 Names.registerFieldDict fields $
77 Opt.Function [N.dollar] (Opt.Call object [Opt.List keyValuePairs])
81-- ENCODE HELPERS
84encodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
85encodeMaybe tipe =
86 do null <- encode "null"
87 encoder <- toEncoder tipe
89 let test = (DT.Empty, DT.IsCtor 2 "Just" Index.first)
90 let just = Opt.Call encoder [ Opt.Index (Opt.VarLocal N.dollar) 0 ]
91 let leaf expr = Opt.Leaf (Opt.Inline expr)
93 return $ Opt.Function [N.dollar] $
94 Opt.Case N.dollar N.dollar (Opt.Chain [test] (leaf just) (leaf null)) []
97encodeList :: Can.Type -> Names.Tracker Opt.Expr
98encodeList tipe =
99 do list <- encode "list"
100 map_ <- Names.registerGlobal ModuleName.list "map"
101 encoder <- toEncoder tipe
102 return $
103 Opt.Function [N.dollar] $
104 Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal N.dollar ] ]
107encodeArray :: Can.Type -> Names.Tracker Opt.Expr
108encodeArray tipe =
109 do array <- encode "array"
110 map_ <- Names.registerGlobal ModuleName.array "map"
111 encoder <- toEncoder tipe
112 return $
113 Opt.Function [N.dollar] $
114 Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal N.dollar ] ]
117encodeTuple :: Can.Type -> Can.Type -> Maybe Can.Type -> Names.Tracker Opt.Expr
118encodeTuple a b maybeC =
119 let
120 convert index tipe =
121 do encoder <- toEncoder tipe
122 return $ Opt.Call encoder [ Opt.Index (Opt.VarLocal N.dollar) index ]
123 in
124 Opt.Function [N.dollar] <$> (
125 Opt.Call
126 <$> encode "list"
127 <*>
128 case maybeC of
129 Nothing ->
130 sequence [ convert 0 a, convert 1 b ]
132 Just c ->
133 sequence [ convert 0 a, convert 1 b, convert 2 c ]
134 )
138-- FLAGS DECODER
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 ]
148 _ ->
149 toDecoder tipe
153-- DECODE
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"
162 Can.TVar _ ->
163 error "type variables should not be allowed through input ports"
165 Can.TAlias _ _ args alias ->
166 toDecoder (Type.dealias args alias)
168 Can.TUnit ->
169 decodeTuple0
171 Can.TTuple a b c ->
172 decodeTuple a b c
174 Can.TType _ name args ->
175 case args of
176 []
177 | name == N.float -> decode "float"
178 | name == N.int -> decode "int"
179 | name == N.bool -> decode "bool"
180 | name == N.string -> decode "string"
181 | name == N.value -> decode "value"
183 [arg]
184 | name == N.maybe -> decodeMaybe arg
185 | name == N.list -> decodeList arg
186 | name == N.array -> decodeArray arg
188 _ ->
189 error "toDecoder: bad type"
191 Can.TRecord _ (Just _) ->
192 error "toDecoder: bad record"
194 Can.TRecord fields Nothing ->
195 decodeRecord fields
199-- DECODE MAYBE
202decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr
203decodeMaybe tipe =
204 do nothing <- Names.registerGlobal ModuleName.maybe "Nothing"
205 just <- Names.registerGlobal ModuleName.maybe "Just"
207 oneOf <- decode "oneOf"
208 null <- decode "null"
209 map_ <- decode "map"
211 subDecoder <- toDecoder tipe
213 return $
214 Opt.Call oneOf
215 [ Opt.List
216 [ Opt.Call null [ nothing ]
217 , Opt.Call map_ [ just, subDecoder ]
218 ]
219 ]
222-- DECODE LIST
225decodeList :: Can.Type -> Names.Tracker Opt.Expr
226decodeList tipe =
227 do list <- decode "list"
228 decoder <- toDecoder tipe
229 return $ Opt.Call list [ decoder ]
233-- DECODE ARRAY
236decodeArray :: Can.Type -> Names.Tracker Opt.Expr
237decodeArray tipe =
238 do array <- decode "array"
239 decoder <- toDecoder tipe
240 return $ Opt.Call array [ decoder ]
244-- DECODE TUPLES
247decodeTuple0 :: Names.Tracker Opt.Expr
248decodeTuple0 =
249 do null <- decode "null"
250 return (Opt.Call null [ Opt.Unit ])
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])
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])
269toLocal :: Int -> Opt.Expr
270toLocal index =
271 Opt.VarLocal (N.localFromInt index)
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 [N.localFromInt i] decoder
282 , Opt.Call index [ Opt.Int i, typeDecoder ]
283 ]
287-- DECODE RECORDS
290decodeRecord :: Map.Map N.Name Can.Type -> Names.Tracker Opt.Expr
291decodeRecord fields =
292 let
293 toFieldExpr name _ =
294 Opt.VarLocal name
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)
304fieldAndThen :: Opt.Expr -> (N.Name, Can.Type) -> Names.Tracker Opt.Expr
305fieldAndThen decoder (key, 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 key, typeDecoder ]
313 ]
317-- GLOBALS HELPERS
320encode :: N.Name -> Names.Tracker Opt.Expr
321encode name =
322 Names.registerGlobal ModuleName.jsonEncode name
325decode :: N.Name -> Names.Tracker Opt.Expr
326decode name =
327 Names.registerGlobal ModuleName.jsonDecode name