git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Optimize/Port.hs
313 lines 7.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Port
4 ( toEncoder
5 , toDecoder
6 )
7 where
10import Prelude hiding (maybe, null)
11import Control.Monad (foldM, zipWithM)
12import qualified Data.Text as Text
13import Data.Text (Text)
15import qualified AST.Expression.Optimized as Opt
16import qualified AST.Helpers as Help
17import qualified AST.Literal as Literal
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Type as T
20import qualified AST.Variable as Var
21import qualified Optimize.DecisionTree as DT
22import qualified Optimize.Environment as Env
26-- ENCODE
29toEncoder :: T.Canonical -> Env.Optimizer Opt.Expr
30toEncoder tipe =
31 case tipe of
32 T.Aliased _ args t ->
33 toEncoder (T.dealias args t)
35 T.Lambda _ _ ->
36 error "toEncoder: function"
38 T.Var _ ->
39 error "toEncoder: type variable"
41 T.Type name
42 | Var.isPrim "Float" name -> encode "float"
43 | Var.isPrim "Int" name -> encode "int"
44 | Var.isPrim "Bool" name -> encode "bool"
45 | Var.isPrim "String" name -> encode "string"
46 | Var.isJson name -> encode "string"
47 | Var.isTuple name -> encode "null"
48 | otherwise -> error "toEncoder: bad type"
50 T.App (T.Type name) [arg]
51 | Var.isMaybe name -> encodeMaybe arg
52 | Var.isList name -> encodeList arg
53 | Var.isArray name -> encodeArray arg
54 | otherwise -> error "toEncoder: bad union type"
56 T.App (T.Type name) args
57 | Var.isTuple name -> encodeTuple args
59 T.App _ _ ->
60 error "toEncoder: bad union type"
62 T.Record _ (Just _) ->
63 error "toEncoder: bad record"
65 T.Record fields Nothing ->
66 let
67 convert (field, typ) =
68 do encoder <- toEncoder typ
69 return
70 ( field
71 , Opt.Call encoder [ Opt.Access (Opt.VarLocal "r") field ]
72 )
73 in
74 do record <- traverse convert fields
75 return $ Opt.Function ["r"] (Opt.Record record)
79-- ENCODE HELPERS
82encodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
83encodeMaybe tipe =
84 do null <- encode "null"
85 encoder <- toEncoder tipe
87 let nothing = Var.inCore "Maybe" "Nothing"
88 let test = (DT.Empty, DT.Constructor nothing)
89 let just = Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "m") 0 ]
90 let leaf expr = Opt.Leaf (Opt.Inline expr)
92 return $ Opt.Function ["m"] $
93 Opt.Case "m" (Opt.Chain [test] (leaf null) (leaf just)) []
96encodeList :: T.Canonical -> Env.Optimizer Opt.Expr
97encodeList tipe =
98 do list <- encode "list"
99 map_ <- core "List" "map"
100 encoder <- toEncoder tipe
101 return $
102 Opt.Function ["xs"] $
103 Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
106encodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
107encodeArray tipe =
108 do array <- encode "array"
109 map_ <- core "Array" "map"
110 encoder <- toEncoder tipe
111 return $
112 Opt.Function ["xs"] $
113 Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
116encodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
117encodeTuple tipes =
118 let
119 convert tipe index =
120 do encoder <- toEncoder tipe
121 return $
122 Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "t") index ]
123 in
124 do list <- encode "list"
125 entries <- zipWithM convert tipes [ 0 .. length tipes ]
126 return $ Opt.Function ["t"] $ Opt.Call list entries
130-- DECODE
133toDecoder :: T.Canonical -> Env.Optimizer Opt.Expr
134toDecoder tipe =
135 case tipe of
136 T.Lambda _ _ ->
137 error "functions should not be allowed through input ports"
139 T.Var _ ->
140 error "type variables should not be allowed through input ports"
142 T.Aliased _ args t ->
143 toDecoder (T.dealias args t)
145 T.Type name
146 | Var.isPrim "Float" name -> decode "float"
147 | Var.isPrim "Int" name -> decode "int"
148 | Var.isPrim "Bool" name -> decode "bool"
149 | Var.isPrim "String" name -> decode "string"
150 | Var.isJson name -> decode "value"
151 | Var.isTuple name -> decodeTuple0
152 | otherwise -> error "toDecoder: bad type"
154 T.App (T.Type name) [arg]
155 | Var.isMaybe name -> decodeMaybe arg
156 | Var.isList name -> decodeList arg
157 | Var.isArray name -> decodeArray arg
158 | otherwise -> error "toDecoder: bad union type"
160 T.App (T.Type name) args
161 | Var.isTuple name -> decodeTuple args
163 T.App _ _ ->
164 error "toDecoder: bad union type"
166 T.Record _ (Just _) ->
167 error "toDecoder: bad record"
169 T.Record fields Nothing ->
170 decodeRecord fields
174-- DECODE MAYBE
177decodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
178decodeMaybe tipe =
179 do let nothing = Var.Global (ModuleName.inCore "Maybe") "Nothing"
180 let just = Var.Global (ModuleName.inCore "Maybe") "Just"
182 Env.register nothing
183 Env.register just
185 oneOf <- decode "oneOf"
186 null <- decode "null"
187 map_ <- decode "map"
189 subDecoder <- toDecoder tipe
191 return $
192 Opt.Call oneOf
193 [ Opt.List
194 [ Opt.Call null [ Opt.VarGlobal nothing ]
195 , Opt.Call map_ [ Opt.VarGlobal just, subDecoder ]
196 ]
197 ]
200-- DECODE LIST
203decodeList :: T.Canonical -> Env.Optimizer Opt.Expr
204decodeList tipe =
205 do list <- decode "list"
206 decoder <- toDecoder tipe
207 return $ Opt.Call list [ decoder ]
211-- DECODE ARRAY
214decodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
215decodeArray tipe =
216 do array <- decode "array"
217 decoder <- toDecoder tipe
218 return $ Opt.Call array [ decoder ]
222-- DECODE TUPLES
225decodeTuple0 :: Env.Optimizer Opt.Expr
226decodeTuple0 =
227 do null <- decode "null"
228 return (Opt.Call null [ Opt.Ctor Help.zeroTuple [] ])
231decodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
232decodeTuple types =
233 let
234 size =
235 length types
237 entries =
238 zip [ 0 .. size - 1] types
240 tuple =
241 Opt.Ctor
242 (Help.makeTuple size)
243 (map (Opt.VarLocal . indexToName . fst) entries)
244 in
245 do succeed <- decode "succeed"
246 foldM indexAndThen (Opt.Call succeed [tuple]) entries
249indexToName :: Int -> Text
250indexToName index =
251 Text.pack ('x' : show index)
254indexAndThen :: Opt.Expr -> (Int, T.Canonical) -> Env.Optimizer Opt.Expr
255indexAndThen decoder (i, tipe) =
256 do andThen <- decode "andThen"
257 index <- decode "index"
258 typeDecoder <- toDecoder tipe
259 return $
260 Opt.Call andThen
261 [ Opt.Function [indexToName i] decoder
262 , Opt.Call index [ Opt.Literal (Literal.IntNum i), typeDecoder ]
263 ]
267-- DECODE RECORDS
270decodeRecord :: [(Text, T.Canonical)] -> Env.Optimizer Opt.Expr
271decodeRecord fields =
272 let
273 toFieldExpr (key, _) =
274 (key, Opt.VarLocal key)
276 record =
277 Opt.Record (map toFieldExpr fields)
278 in
279 do succeed <- decode "succeed"
280 foldM fieldAndThen (Opt.Call succeed [record]) fields
283fieldAndThen :: Opt.Expr -> (Text, T.Canonical) -> Env.Optimizer Opt.Expr
284fieldAndThen decoder (key, tipe) =
285 do andThen <- decode "andThen"
286 field <- decode "field"
287 typeDecoder <- toDecoder tipe
288 return $
289 Opt.Call andThen
290 [ Opt.Function [key] decoder
291 , Opt.Call field [ Opt.Literal (Literal.Str key), typeDecoder ]
292 ]
296-- GLOBALS HELPERS
299core :: Text -> Text -> Env.Optimizer Opt.Expr
300core home name =
301 do let var = Var.Global (ModuleName.inCore home) name
302 Env.register var
303 return (Opt.VarGlobal var)
306encode :: Text -> Env.Optimizer Opt.Expr
307encode name =
308 core "Json.Encode" name
311decode :: Text -> Env.Optimizer Opt.Expr
312decode name =
313 core "Json.Decode" name