1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE OverloadedStrings #-} 3module Optimize.Port 4 ( toEncoder 5 , toFlagsDecoder 6 , toDecoder 7 ) 8 where 9 10 11import Prelude hiding (maybe, null) 12import Control.Monad (foldM) 13import qualified Data.Map as Map 14import qualified Data.Name as Name 15 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 22 23 24 25-- ENCODE 26 27 28toEncoder :: Can.Type -> Names.Tracker Opt.Expr 29toEncoder tipe = 30 case tipe of 31 Can.TAlias _ _ args alias -> 32 toEncoder (Type.dealias args alias) 33 34 Can.TLambda _ _ -> 35 error "toEncoder: function" 36 37 Can.TVar _ -> 38 error "toEncoder: type variable" 39 40 Can.TUnit -> 41 Opt.Function [Name.dollar] <$> encode "null" 42 43 Can.TTuple a b c -> 44 encodeTuple a b c 45 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 54 55 [arg] 56 | name == Name.maybe -> encodeMaybe arg 57 | name == Name.list -> encodeList arg 58 | name == Name.array -> encodeArray arg 59 60 _ -> 61 error "toEncoder: bad custom type" 62 63 Can.TRecord _ (Just _) -> 64 error "toEncoder: bad record" 65 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]) 77 78 79 80-- ENCODE HELPERS 81 82 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 ] 90 91 92encodeList :: Can.Type -> Names.Tracker Opt.Expr 93encodeList tipe = 94 do list <- encode "list" 95 encoder <- toEncoder tipe 96 return $ Opt.Call list [ encoder ] 97 98 99encodeArray :: Can.Type -> Names.Tracker Opt.Expr 100encodeArray tipe = 101 do array <- encode "array" 102 encoder <- toEncoder tipe 103 return $ Opt.Call array [ encoder ] 104 105 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 111 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 120 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 ] ] 127 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 ] ] 135 136 137 138-- FLAGS DECODER 139 140 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 ] 147 148 _ -> 149 toDecoder tipe 150 151 152 153-- DECODE 154 155 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" 161 162 Can.TVar _ -> 163 error "type variables should not be allowed through input ports" 164 165 Can.TAlias _ _ args alias -> 166 toDecoder (Type.dealias args alias) 167 168 Can.TUnit -> 169 decodeTuple0 170 171 Can.TTuple a b c -> 172 decodeTuple a b c 173 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" 182 183 [arg] 184 | name == Name.maybe -> decodeMaybe arg 185 | name == Name.list -> decodeList arg 186 | name == Name.array -> decodeArray arg 187 188 _ -> 189 error "toDecoder: bad type" 190 191 Can.TRecord _ (Just _) -> 192 error "toDecoder: bad record" 193 194 Can.TRecord fields Nothing -> 195 decodeRecord fields 196 197 198 199-- DECODE MAYBE 200 201 202decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr 203decodeMaybe tipe = 204 do nothing <- Names.registerGlobal ModuleName.maybe "Nothing" 205 just <- Names.registerGlobal ModuleName.maybe "Just" 206 207 oneOf <- decode "oneOf" 208 null <- decode "null" 209 map_ <- decode "map" 210 211 subDecoder <- toDecoder tipe 212 213 return $ 214 Opt.Call oneOf 215 [ Opt.List 216 [ Opt.Call null [ nothing ] 217 , Opt.Call map_ [ just, subDecoder ] 218 ] 219 ] 220 221 222-- DECODE LIST 223 224 225decodeList :: Can.Type -> Names.Tracker Opt.Expr 226decodeList tipe = 227 do list <- decode "list" 228 decoder <- toDecoder tipe 229 return $ Opt.Call list [ decoder ] 230 231 232 233-- DECODE ARRAY 234 235 236decodeArray :: Can.Type -> Names.Tracker Opt.Expr 237decodeArray tipe = 238 do array <- decode "array" 239 decoder <- toDecoder tipe 240 return $ Opt.Call array [ decoder ] 241 242 243 244-- DECODE TUPLES 245 246 247decodeTuple0 :: Names.Tracker Opt.Expr 248decodeTuple0 = 249 do null <- decode "null" 250 return (Opt.Call null [ Opt.Unit ]) 251 252 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]) 261 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]) 267 268 269toLocal :: Int -> Opt.Expr 270toLocal index = 271 Opt.VarLocal (Name.fromVarIndex index) 272 273 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 ] 284 285 286 287-- DECODE RECORDS 288 289 290decodeRecord :: Map.Map Name.Name Can.FieldType -> Names.Tracker Opt.Expr 291decodeRecord fields = 292 let 293 toFieldExpr name _ = 294 Opt.VarLocal name 295 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) 302 303 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 ] 314 315 316 317-- GLOBALS HELPERS 318 319 320encode :: Name.Name -> Names.Tracker Opt.Expr 321encode name = 322 Names.registerGlobal ModuleName.jsonEncode name 323 324 325decode :: Name.Name -> Names.Tracker Opt.Expr 326decode name = 327 Names.registerGlobal ModuleName.jsonDecode name 328