git.iko.soy/elk
on ea77dcf help sign in
elk/src/Optimize/Port.hs
329 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, zipWithM)
13import qualified Data.Text as Text
14import Data.Text (Text)
16import qualified AST.Expression.Optimized as Opt
17import qualified AST.Helpers as Help
18import qualified AST.Literal as Literal
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Type as T
21import qualified AST.Variable as Var
22import qualified Optimize.DecisionTree as DT
23import qualified Optimize.Environment as Env
27-- ENCODE
30toEncoder :: T.Canonical -> Env.Optimizer Opt.Expr
31toEncoder tipe =
32 case tipe of
33 T.Aliased _ args t ->
34 toEncoder (T.dealias args t)
36 T.Lambda _ _ ->
37 error "toEncoder: function"
39 T.Var _ ->
40 error "toEncoder: type variable"
42 T.Type name []
43 | Var.isPrim "Float" name -> encode "float"
44 | Var.isPrim "Int" name -> encode "int"
45 | Var.isPrim "Bool" name -> encode "bool"
46 | Var.isPrim "String" name -> encode "string"
47 | Var.isJson name -> encode "value"
48 | Var.isTuple name -> encode "null"
49 | otherwise -> error "toEncoder: bad type"
51 T.Type name [arg]
52 | Var.isMaybe name -> encodeMaybe arg
53 | Var.isList name -> encodeList arg
54 | Var.isArray name -> encodeArray arg
55 | otherwise -> error "toEncoder: bad union type"
57 T.Type name args
58 | Var.isTuple name -> encodeTuple args
60 T.Type _ _ ->
61 error "toEncoder: bad union type"
63 T.Record _ (Just _) ->
64 error "toEncoder: bad record"
66 T.Record fields Nothing ->
67 let
68 convert (field, typ) =
69 do encoder <- toEncoder typ
70 return
71 ( field
72 , Opt.Call encoder [ Opt.Access (Opt.VarLocal "r") field ]
73 )
74 in
75 do record <- traverse convert fields
76 return $ Opt.Function ["r"] (Opt.Record record)
80-- ENCODE HELPERS
83encodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
84encodeMaybe tipe =
85 do null <- encode "null"
86 encoder <- toEncoder tipe
88 let nothing = Var.inCore "Maybe" "Nothing"
89 let test = (DT.Empty, DT.Constructor nothing)
90 let just = Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "m") 0 ]
91 let leaf expr = Opt.Leaf (Opt.Inline expr)
93 return $ Opt.Function ["m"] $
94 Opt.Case "m" (Opt.Chain [test] (leaf null) (leaf just)) []
97encodeList :: T.Canonical -> Env.Optimizer Opt.Expr
98encodeList tipe =
99 do list <- encode "list"
100 map_ <- core "List" "map"
101 encoder <- toEncoder tipe
102 return $
103 Opt.Function ["xs"] $
104 Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
107encodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
108encodeArray tipe =
109 do array <- encode "array"
110 map_ <- core "Array" "map"
111 encoder <- toEncoder tipe
112 return $
113 Opt.Function ["xs"] $
114 Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
117encodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
118encodeTuple tipes =
119 let
120 convert tipe index =
121 do encoder <- toEncoder tipe
122 return $
123 Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "t") index ]
124 in
125 do list <- encode "list"
126 entries <- zipWithM convert tipes [ 0 .. length tipes ]
127 return $ Opt.Function ["t"] $ Opt.Call list entries
131-- FLAGS DECODER
134toFlagsDecoder :: T.Canonical -> Env.Optimizer Opt.Expr
135toFlagsDecoder tipe =
136 case tipe of
137 T.Type name [] | Var.isTuple name ->
138 do succeed <- decode "succeed"
139 return $ Opt.Call succeed [ Opt.Ctor Help.zeroTuple [] ]
141 _ ->
142 toDecoder tipe
146-- DECODE
149toDecoder :: T.Canonical -> Env.Optimizer Opt.Expr
150toDecoder tipe =
151 case tipe of
152 T.Lambda _ _ ->
153 error "functions should not be allowed through input ports"
155 T.Var _ ->
156 error "type variables should not be allowed through input ports"
158 T.Aliased _ args t ->
159 toDecoder (T.dealias args t)
161 T.Type name []
162 | Var.isPrim "Float" name -> decode "float"
163 | Var.isPrim "Int" name -> decode "int"
164 | Var.isPrim "Bool" name -> decode "bool"
165 | Var.isPrim "String" name -> decode "string"
166 | Var.isJson name -> decode "value"
167 | Var.isTuple name -> decodeTuple0
168 | otherwise -> error "toDecoder: bad type"
170 T.Type name [arg]
171 | Var.isMaybe name -> decodeMaybe arg
172 | Var.isList name -> decodeList arg
173 | Var.isArray name -> decodeArray arg
174 | otherwise -> error "toDecoder: bad union type"
176 T.Type name args
177 | Var.isTuple name -> decodeTuple args
179 T.Type _ _ ->
180 error "toDecoder: bad union type"
182 T.Record _ (Just _) ->
183 error "toDecoder: bad record"
185 T.Record fields Nothing ->
186 decodeRecord fields
190-- DECODE MAYBE
193decodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
194decodeMaybe tipe =
195 do let nothing = Var.Global (ModuleName.inCore "Maybe") "Nothing"
196 let just = Var.Global (ModuleName.inCore "Maybe") "Just"
198 Env.register nothing
199 Env.register just
201 oneOf <- decode "oneOf"
202 null <- decode "null"
203 map_ <- decode "map"
205 subDecoder <- toDecoder tipe
207 return $
208 Opt.Call oneOf
209 [ Opt.List
210 [ Opt.Call null [ Opt.VarGlobal nothing ]
211 , Opt.Call map_ [ Opt.VarGlobal just, subDecoder ]
212 ]
213 ]
216-- DECODE LIST
219decodeList :: T.Canonical -> Env.Optimizer Opt.Expr
220decodeList tipe =
221 do list <- decode "list"
222 decoder <- toDecoder tipe
223 return $ Opt.Call list [ decoder ]
227-- DECODE ARRAY
230decodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
231decodeArray tipe =
232 do array <- decode "array"
233 decoder <- toDecoder tipe
234 return $ Opt.Call array [ decoder ]
238-- DECODE TUPLES
241decodeTuple0 :: Env.Optimizer Opt.Expr
242decodeTuple0 =
243 do null <- decode "null"
244 return (Opt.Call null [ Opt.Ctor Help.zeroTuple [] ])
247decodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
248decodeTuple types =
249 let
250 size =
251 length types
253 entries =
254 zip [ 0 .. size - 1] types
256 tuple =
257 Opt.Ctor
258 (Help.makeTuple size)
259 (map (Opt.VarLocal . indexToName . fst) entries)
260 in
261 do succeed <- decode "succeed"
262 foldM indexAndThen (Opt.Call succeed [tuple]) entries
265indexToName :: Int -> Text
266indexToName index =
267 Text.pack ('x' : show index)
270indexAndThen :: Opt.Expr -> (Int, T.Canonical) -> Env.Optimizer Opt.Expr
271indexAndThen decoder (i, tipe) =
272 do andThen <- decode "andThen"
273 index <- decode "index"
274 typeDecoder <- toDecoder tipe
275 return $
276 Opt.Call andThen
277 [ Opt.Function [indexToName i] decoder
278 , Opt.Call index [ Opt.Literal (Literal.IntNum i), typeDecoder ]
279 ]
283-- DECODE RECORDS
286decodeRecord :: [(Text, T.Canonical)] -> Env.Optimizer Opt.Expr
287decodeRecord fields =
288 let
289 toFieldExpr (key, _) =
290 (key, Opt.VarLocal key)
292 record =
293 Opt.Record (map toFieldExpr fields)
294 in
295 do succeed <- decode "succeed"
296 foldM fieldAndThen (Opt.Call succeed [record]) fields
299fieldAndThen :: Opt.Expr -> (Text, T.Canonical) -> Env.Optimizer Opt.Expr
300fieldAndThen decoder (key, tipe) =
301 do andThen <- decode "andThen"
302 field <- decode "field"
303 typeDecoder <- toDecoder tipe
304 return $
305 Opt.Call andThen
306 [ Opt.Function [key] decoder
307 , Opt.Call field [ Opt.Literal (Literal.Str key), typeDecoder ]
308 ]
312-- GLOBALS HELPERS
315core :: Text -> Text -> Env.Optimizer Opt.Expr
316core home name =
317 do let var = Var.Global (ModuleName.inCore home) name
318 Env.register var
319 return (Opt.VarGlobal var)
322encode :: Text -> Env.Optimizer Opt.Expr
323encode name =
324 core "Json.Encode" name
327decode :: Text -> Env.Optimizer Opt.Expr
328decode name =
329 core "Json.Decode" name