git.iko.soy/elk
on 774aebd help sign in
elk/src/Optimize/Port.hs
312 lines 7.7 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.Literal as Literal
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Type as T
19import qualified AST.Variable as Var
20import qualified Optimize.DecisionTree as DT
21import qualified Optimize.Environment as Env
25-- ENCODE
28toEncoder :: T.Canonical -> Env.Optimizer Opt.Expr
29toEncoder tipe =
30 case tipe of
31 T.Aliased _ args t ->
32 toEncoder (T.dealias args t)
34 T.Lambda _ _ ->
35 error "toEncoder: function"
37 T.Var _ ->
38 error "toEncoder: type variable"
40 T.Type name
41 | Var.isPrim "Float" name -> encode "float"
42 | Var.isPrim "Int" name -> encode "int"
43 | Var.isPrim "Bool" name -> encode "bool"
44 | Var.isPrim "String" name -> encode "string"
45 | Var.isJson name -> encode "string"
46 | Var.isTuple name -> encode "null"
47 | otherwise -> error "toEncoder: bad type"
49 T.App (T.Type name) [arg]
50 | Var.isMaybe name -> encodeMaybe arg
51 | Var.isList name -> encodeList arg
52 | Var.isArray name -> encodeArray arg
53 | otherwise -> error "toEncoder: bad union type"
55 T.App (T.Type name) args
56 | Var.isTuple name -> encodeTuple args
58 T.App _ _ ->
59 error "toEncoder: bad union type"
61 T.Record _ (Just _) ->
62 error "toEncoder: bad record"
64 T.Record fields Nothing ->
65 let
66 convert (field, typ) =
67 do encoder <- toEncoder typ
68 return
69 ( field
70 , Opt.Call encoder [ Opt.Access (Opt.VarLocal "r") field ]
71 )
72 in
73 do record <- traverse convert fields
74 return $ Opt.Function ["r"] (Opt.Record record)
78-- ENCODE HELPERS
81encodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
82encodeMaybe tipe =
83 do null <- encode "null"
84 encoder <- toEncoder tipe
86 let nothing = Var.inCore "Maybe" "Nothing"
87 let test = (DT.Empty, DT.Constructor nothing)
88 let just = Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "m") 0 ]
89 let leaf expr = Opt.Leaf (Opt.Inline expr)
91 return $ Opt.Function ["m"] $
92 Opt.Case "m" (Opt.Chain [test] (leaf null) (leaf just)) []
95encodeList :: T.Canonical -> Env.Optimizer Opt.Expr
96encodeList tipe =
97 do list <- encode "list"
98 map_ <- core "List" "map"
99 encoder <- toEncoder tipe
100 return $
101 Opt.Function ["xs"] $
102 Opt.Call list [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
105encodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
106encodeArray tipe =
107 do array <- encode "array"
108 map_ <- core "Array" "map"
109 encoder <- toEncoder tipe
110 return $
111 Opt.Function ["xs"] $
112 Opt.Call array [ Opt.Call map_ [ encoder, Opt.VarLocal "xs" ] ]
115encodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
116encodeTuple tipes =
117 let
118 convert tipe index =
119 do encoder <- toEncoder tipe
120 return $
121 Opt.Call encoder [ Opt.CtorAccess (Opt.VarLocal "t") index ]
122 in
123 do list <- encode "list"
124 entries <- zipWithM convert tipes [ 0 .. length tipes ]
125 return $ Opt.Function ["t"] $ Opt.Call list entries
129-- DECODE
132toDecoder :: T.Canonical -> Env.Optimizer Opt.Expr
133toDecoder tipe =
134 case tipe of
135 T.Lambda _ _ ->
136 error "functions should not be allowed through input ports"
138 T.Var _ ->
139 error "type variables should not be allowed through input ports"
141 T.Aliased _ args t ->
142 toDecoder (T.dealias args t)
144 T.Type name
145 | Var.isPrim "Float" name -> decode "float"
146 | Var.isPrim "Int" name -> decode "int"
147 | Var.isPrim "Bool" name -> decode "bool"
148 | Var.isPrim "String" name -> decode "string"
149 | Var.isJson name -> decode "value"
150 | Var.isTuple name -> decodeTuple0
151 | otherwise -> error "toDecoder: bad type"
153 T.App (T.Type name) [arg]
154 | Var.isMaybe name -> decodeMaybe arg
155 | Var.isList name -> decodeList arg
156 | Var.isArray name -> decodeArray arg
157 | otherwise -> error "toDecoder: bad union type"
159 T.App (T.Type name) args
160 | Var.isTuple name -> decodeTuple args
162 T.App _ _ ->
163 error "toDecoder: bad union type"
165 T.Record _ (Just _) ->
166 error "toDecoder: bad record"
168 T.Record fields Nothing ->
169 decodeRecord fields
173-- DECODE MAYBE
176decodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr
177decodeMaybe tipe =
178 do let nothing = Var.Global (ModuleName.inCore "Maybe") "Nothing"
179 let just = Var.Global (ModuleName.inCore "Maybe") "Just"
181 Env.register nothing
182 Env.register just
184 oneOf <- decode "oneOf"
185 null <- decode "null"
186 map_ <- decode "map"
188 subDecoder <- toDecoder tipe
190 return $
191 Opt.Call oneOf
192 [ Opt.List
193 [ Opt.Call null [ Opt.VarGlobal nothing ]
194 , Opt.Call map_ [ Opt.VarGlobal just, subDecoder ]
195 ]
196 ]
199-- DECODE LIST
202decodeList :: T.Canonical -> Env.Optimizer Opt.Expr
203decodeList tipe =
204 do list <- decode "list"
205 decoder <- toDecoder tipe
206 return $ Opt.Call list [ decoder ]
210-- DECODE ARRAY
213decodeArray :: T.Canonical -> Env.Optimizer Opt.Expr
214decodeArray tipe =
215 do array <- decode "array"
216 decoder <- toDecoder tipe
217 return $ Opt.Call array [ decoder ]
221-- DECODE TUPLES
224decodeTuple0 :: Env.Optimizer Opt.Expr
225decodeTuple0 =
226 do null <- decode "null"
227 return (Opt.Call null [ Opt.Ctor "_Tuple0" [] ])
230decodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr
231decodeTuple types =
232 let
233 size =
234 length types
236 entries =
237 zip [ 0 .. size - 1] types
239 tuple =
240 Opt.Ctor
241 (Text.pack ("_Tuple" ++ show size))
242 (map (Opt.VarLocal . indexToName . fst) entries)
243 in
244 do succeed <- decode "succeed"
245 foldM indexAndThen (Opt.Call succeed [tuple]) entries
248indexToName :: Int -> Text
249indexToName index =
250 Text.pack ('x' : show index)
253indexAndThen :: Opt.Expr -> (Int, T.Canonical) -> Env.Optimizer Opt.Expr
254indexAndThen decoder (i, tipe) =
255 do andThen <- decode "andThen"
256 index <- decode "index"
257 typeDecoder <- toDecoder tipe
258 return $
259 Opt.Call andThen
260 [ Opt.Function [indexToName i] decoder
261 , Opt.Call index [ Opt.Literal (Literal.IntNum i), typeDecoder ]
262 ]
266-- DECODE RECORDS
269decodeRecord :: [(Text, T.Canonical)] -> Env.Optimizer Opt.Expr
270decodeRecord fields =
271 let
272 toFieldExpr (key, _) =
273 (key, Opt.VarLocal key)
275 record =
276 Opt.Record (map toFieldExpr fields)
277 in
278 do succeed <- decode "succeed"
279 foldM fieldAndThen (Opt.Call succeed [record]) fields
282fieldAndThen :: Opt.Expr -> (Text, T.Canonical) -> Env.Optimizer Opt.Expr
283fieldAndThen decoder (key, tipe) =
284 do andThen <- decode "andThen"
285 field <- decode "field"
286 typeDecoder <- toDecoder tipe
287 return $
288 Opt.Call andThen
289 [ Opt.Function [key] decoder
290 , Opt.Call field [ Opt.Literal (Literal.Str key), typeDecoder ]
291 ]
295-- GLOBALS HELPERS
298core :: Text -> Text -> Env.Optimizer Opt.Expr
299core home name =
300 do let var = Var.Global (ModuleName.inCore home) name
301 Env.register var
302 return (Opt.VarGlobal var)
305encode :: Text -> Env.Optimizer Opt.Expr
306encode name =
307 core "Json.Encode" name
310decode :: Text -> Env.Optimizer Opt.Expr
311decode name =
312 core "Json.Decode" name