git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Optimize/Port.hs
327 lines 8.3 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
14import qualified Data.Name as Name
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
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 Opt.Function [Name.dollar] <$> 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 == 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
55 [arg]
56 | name == Name.maybe -> encodeMaybe arg
57 | name == Name.list -> encodeList arg
58 | name == Name.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, 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])
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 [Name.dollar] $
89 Opt.Call destruct [ null, encoder, Opt.VarLocal Name.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 Name.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 identity <- Names.registerGlobal ModuleName.basics Name.identity
118 arg1 <- encodeArg "a" a
119 arg2 <- encodeArg "b" b
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 ] ]
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 ] ]
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 == 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"
183 [arg]
184 | name == Name.maybe -> decodeMaybe arg
185 | name == Name.list -> decodeList arg
186 | name == Name.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 (Name.fromVarIndex 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 [Name.fromVarIndex i] decoder
282 , Opt.Call index [ Opt.Int i, typeDecoder ]
283 ]
287-- DECODE RECORDS
290decodeRecord :: Map.Map Name.Name Can.FieldType -> 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 -> (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 ]
317-- GLOBALS HELPERS
320encode :: Name.Name -> Names.Tracker Opt.Expr
321encode name =
322 Names.registerGlobal ModuleName.jsonEncode name
325decode :: Name.Name -> Names.Tracker Opt.Expr
326decode name =
327 Names.registerGlobal ModuleName.jsonDecode name