c0aed6f · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Shuffle some code so that port deps get registered for DCE

c0aed6fEvan Czaplicki10 years ago

elm-compiler.cabal+1−1

compare with master

unifiedsplit

@@ -94,7 +94,6 @@ Library

94 Generate.JavaScript.BuiltIn,

95 Generate.JavaScript.Effects,

96 Generate.JavaScript.Expression,

97− Generate.JavaScript.Foreign,

98 Generate.JavaScript.Helpers,

97 Generate.JavaScript.Helpers,

99 Generate.JavaScript.Literal,

98 Generate.JavaScript.Literal,

100 Generate.JavaScript.Variable,

99 Generate.JavaScript.Variable,

@@ -106,6 +105,7 @@ Library

106 Optimize.DecisionTree,

105 Optimize.DecisionTree,

107 Optimize.Environment,

106 Optimize.Environment,

108 Optimize.Inline,

107 Optimize.Inline,

108+ Optimize.Port,

109 Parse.Declaration,

110 Parse.Expression,

111 Parse.Helpers,

src/AST/Expression/Canonical.hs−26

@@ -11,7 +11,6 @@ module AST.Expression.Canonical

11 where

14−import Data.Binary

15import Data.Monoid ((<>))

14import Data.Monoid ((<>))

16import Data.Text (Text)

15import Data.Text (Text)

17import qualified Data.Text.Lazy as LText

16import qualified Data.Text.Lazy as LText

@@ -161,28 +160,3 @@ collectLambdas lexpr@(A.A _ expr) =

161

160

162 _ ->

161 _ ->

163 ([], lexpr)

162 ([], lexpr)

164−

165−

166−

167−-- BINARY

168−

169−

170−instance Binary Main where

171− put main =

172− case main of

173− VDom ->

174− putWord8 0

175−

176− NoFlags ->

177− putWord8 1

178−

179− Flags tipe ->

180− putWord8 2 >> put tipe

181−

182− get =

183− do word <- getWord8

184− case word of

185− 0 -> pure VDom

186− 1 -> pure NoFlags

187− 2 -> pure Flags <*> get

188− _ -> error "problem getting Can.Main binary"

src/AST/Expression/Optimized.hs+26−5

@@ -3,6 +3,7 @@ module AST.Expression.Optimized

3 ( Decl(..)

4 , Def(..)

5 , Expr(..)

6+ , Main(..)

6 , Decider(..), Choice(..)

7 , Decider(..), Choice(..)

7 )

8 )

8 where

9 where

@@ -14,10 +15,8 @@ import qualified Data.Set as Set

14import Data.Text (Text)

15import Data.Text (Text)

16import qualified AST.Effects as Effects

17import qualified AST.Effects as Effects

17−import qualified AST.Expression.Canonical as Can

18import qualified AST.Literal as Literal

19import qualified AST.Module.Name as ModuleName

20−import qualified AST.Type as Type

21import qualified AST.Variable as Var

20import qualified AST.Variable as Var

22import qualified Optimize.DecisionTree as DT

21import qualified Optimize.DecisionTree as DT

23import qualified Reporting.Region as R

22import qualified Reporting.Region as R

@@ -67,13 +66,19 @@ data Expr

67 | Record [(Text, Expr)]

66 | Record [(Text, Expr)]

68 | Cmd ModuleName.Canonical Effects.ManagerType

67 | Cmd ModuleName.Canonical Effects.ManagerType

69 | Sub ModuleName.Canonical Effects.ManagerType

68 | Sub ModuleName.Canonical Effects.ManagerType

70− | OutgoingPort Text Type.Canonical

69+ | OutgoingPort Text Expr

71− | IncomingPort Text Type.Canonical

70+ | IncomingPort Text Expr

72− | Program Can.Main Expr

71+ | Program Main Expr

73 | GLShader Text

72 | GLShader Text

74 | Crash ModuleName.Canonical R.Region (Maybe Expr)

73 | Crash ModuleName.Canonical R.Region (Maybe Expr)

76+data Main

77+ = VDom

78+ | NoFlags

79+ | Flags Expr

80+

81+

77data Decider a

82data Decider a

78 = Leaf a

83 = Leaf a

79 | Chain

84 | Chain

@@ -179,6 +184,22 @@ instance Binary Expr where

179 Crash a b c -> putWord8 22 >> put a >> put b >> put c

184 Crash a b c -> putWord8 22 >> put a >> put b >> put c

180

185

181

186

187+instance Binary Main where

188+ put main =

189+ case main of

190+ VDom -> putWord8 0

191+ NoFlags -> putWord8 1

192+ Flags expr -> putWord8 2 >> put expr

193+

194+ get =

195+ do word <- getWord8

196+ case word of

197+ 0 -> pure VDom

198+ 1 -> pure NoFlags

199+ 2 -> liftM Flags get

200+ _ -> error "problem getting Can.Main binary"

201+

202+

182instance (Binary a) => Binary (Decider a) where

203instance (Binary a) => Binary (Decider a) where

183 get =

204 get =

184 do word <- getWord8

205 do word <- getWord8

src/Generate/JavaScript/Expression.hs+10−12

@@ -13,7 +13,6 @@ import Data.Monoid ((<>))

13import qualified Data.Text as Text

14import Data.Text (Text)

16−import qualified AST.Expression.Canonical as Can

17import AST.Expression.Optimized as Opt

16import AST.Expression.Optimized as Opt

18import qualified AST.Literal as L

17import qualified AST.Literal as L

19import qualified AST.Module.Name as ModuleName

18import qualified AST.Module.Name as ModuleName

@@ -21,7 +20,6 @@ import qualified AST.Variable as V

21import Generate.JavaScript.Helpers as Help

20import Generate.JavaScript.Helpers as Help

22import qualified Generate.JavaScript.Builder as JS

21import qualified Generate.JavaScript.Builder as JS

23import qualified Generate.JavaScript.BuiltIn as BuiltIn

22import qualified Generate.JavaScript.BuiltIn as BuiltIn

24−import qualified Generate.JavaScript.Foreign as Foreign

25import qualified Generate.JavaScript.Literal as Literal

23import qualified Generate.JavaScript.Literal as Literal

26import qualified Generate.JavaScript.Variable as Var

24import qualified Generate.JavaScript.Variable as Var

27import Generate.JavaScript.Variable (Generator)

25import Generate.JavaScript.Variable (Generator)

@@ -200,12 +198,12 @@ generateCode expr =

200 Sub moduleName _ ->

198 Sub moduleName _ ->

201 JsExpr <$> BuiltIn.effect moduleName

199 JsExpr <$> BuiltIn.effect moduleName

202

200

203− OutgoingPort name tipe ->

201+ OutgoingPort name encoder ->

204− do encoder <- Foreign.encode tipe

202+ do jsEncoder <- generateJsExpr encoder

205− JsExpr <$> BuiltIn.outgoingPort name encoder

203+ JsExpr <$> BuiltIn.outgoingPort name jsEncoder

206

204

207− IncomingPort name tipe ->

205+ IncomingPort name decoder ->

208− do jsDecoder <- generateJsExpr (Foreign.decode tipe)

206+ do jsDecoder <- generateJsExpr decoder

209 JsExpr <$> BuiltIn.incomingPort name jsDecoder

207 JsExpr <$> BuiltIn.incomingPort name jsDecoder

210

208

211 Program kind body ->

209 Program kind body ->

@@ -224,21 +222,21 @@ generateCode expr =

224-- PROGRAMS

222-- PROGRAMS

225

223

226

224

227−generateProgram :: Can.Main -> Opt.Expr -> Generator Code

225+generateProgram :: Opt.Main -> Opt.Expr -> Generator Code

228generateProgram kind body =

226generateProgram kind body =

229 case kind of

227 case kind of

230− Can.VDom ->

228+ Opt.VDom ->

231 do html <- generateJsExpr body

229 do html <- generateJsExpr body

232 func <- BuiltIn.staticProgram

230 func <- BuiltIn.staticProgram

233 jsExpr (func <| html)

231 jsExpr (func <| html)

234

232

235− Can.NoFlags ->

233+ Opt.NoFlags ->

236 do almostProgram <- generateJsExpr body

234 do almostProgram <- generateJsExpr body

237 jsExpr (JS.Call almostProgram [])

235 jsExpr (JS.Call almostProgram [])

238

236

239− Can.Flags tipe ->

237+ Opt.Flags decoder ->

240 do almostProgram <- generateJsExpr body

238 do almostProgram <- generateJsExpr body

241− flagDecoder <- generateJsExpr (Foreign.decode tipe)

239+ flagDecoder <- generateJsExpr decoder

242 jsExpr (almostProgram <| flagDecoder)

240 jsExpr (almostProgram <| flagDecoder)

243

241

244

242

src/Generate/JavaScript/Foreign.hsdeleted−240

@@ -1,240 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Generate.JavaScript.Foreign (encode, decode) where

4−

5−import Prelude hiding (maybe)

6−import Control.Monad (zipWithM)

7−import qualified Data.List as List

8−import qualified Data.Text as Text

9−import Data.Text (Text)

10−

11−import qualified AST.Expression.Optimized as Opt

12−import qualified AST.Literal as Literal

13−import qualified AST.Module.Name as ModuleName

14−import qualified AST.Type as T

15−import qualified AST.Variable as Var

16−import qualified Generate.JavaScript.Builder as JS

17−import qualified Generate.JavaScript.Helpers as JS (function, ref)

18−import Generate.JavaScript.Helpers ((<|), (==>))

19−import qualified Generate.JavaScript.Variable as JS (Generator, global)

20−

21−

22−

23−-- ENCODE

24−

25−

26−encode :: T.Canonical -> JS.Generator JS.Expr

27−encode tipe =

28− do js <- encodeHelp tipe (JS.ref "v")

29− return $ JS.function ["v"] [ JS.Return (Just js) ]

30−

31−

32−encodeHelp :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

33−encodeHelp tipe expr =

34− case tipe of

35− T.Aliased _ args t ->

36− encodeHelp (T.dealias args t) expr

37−

38− T.Lambda _ _ ->

39− error "encodeHelp: function"

40−

41− T.Var _ ->

42− error "encodeHelp: type variable"

43−

44− T.Type name

45− | Var.isPrim "Float" name -> pure expr

46− | Var.isPrim "Int" name -> pure expr

47− | Var.isPrim "Bool" name -> pure expr

48− | Var.isPrim "String" name -> pure expr

49− | Var.isJson name -> pure expr

50− | Var.isTuple name -> pure JS.Null

51− | otherwise -> error "encodeHelp: bad type"

52−

53− T.App (T.Type name) [arg]

54− | Var.isMaybe name -> fromMaybe arg expr

55− | Var.isList name -> fromList arg expr

56− | Var.isArray name -> fromArray arg expr

57− | otherwise -> error "encodeHelp: bad union type"

58−

59− T.App (T.Type name) args

60− | Var.isTuple name -> fromTuple args expr

61−

62− T.App _ _ ->

63− error "encodeHelp: bad union type"

64−

65− T.Record _ (Just _) ->

66− error "encodeHelp: bad record"

67−

68− T.Record fields Nothing ->

69− let

70− convert (k, t) =

71− (==>) k <$> encodeHelp t (JS.DotRef expr (JS.Id k))

72− in

73− JS.Object <$> traverse convert fields

74−

75−

76−fromMaybe :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

77−fromMaybe tipe expr =

78− do js <- encodeHelp tipe (JS.DotRef expr (JS.Id "_0"))

79− let isNothing = JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing")

80− return $ JS.If isNothing JS.Null js

81−

82−

83−fromList :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

84−fromList tipe expr =

85− do let var = Var.Global (ModuleName.inCore "Elm.Kernel.List") "toArray"

86− toArray <- JS.global var

87− encoder <- encode tipe

88− return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder

89−

90−

91−fromArray :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

92−fromArray tipe expr =

93− do let var = Var.Global (ModuleName.inCore "Elm.Kernel.Array") "toJSArray"

94− toArray <- JS.global var

95− encoder <- encode tipe

96− return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder

97−

98−

99−fromTuple :: [T.Canonical] -> JS.Expr -> JS.Generator JS.Expr

100−fromTuple types expr =

101− let

102− convert subType n =

103− encodeHelp subType $ JS.DotRef expr (JS.Id (Text.pack ('_':show n)))

104− in

105− JS.Array <$> zipWithM convert types [ 0 .. length types ]

106−

107−

108−

109−-- SUBSCRIPTIONS

110−

111−

112−decode :: T.Canonical -> Opt.Expr

113−decode tipe =

114− case tipe of

115− T.Lambda _ _ ->

116− error "functions should not be allowed through input ports"

117−

118− T.Var _ ->

119− error "type variables should not be allowed through input ports"

120−

121− T.Aliased _ args t ->

122− decode (T.dealias args t)

123−

124− T.Type name

125− | Var.isPrim "Float" name -> to "float"

126− | Var.isPrim "Int" name -> to "int"

127− | Var.isPrim "Bool" name -> to "bool"

128− | Var.isPrim "String" name -> to "string"

129− | Var.isJson name -> to "value"

130− | Var.isTuple name -> toTuple0

131− | otherwise -> error "decode: bad type"

132−

133− T.App (T.Type name) [arg]

134− | Var.isMaybe name -> toMaybe arg

135− | Var.isList name -> to "list" <== [decode arg]

136− | Var.isArray name -> to "array" <== [decode arg]

137− | otherwise -> error "decode: bad union type"

138−

139− T.App (T.Type name) args

140− | Var.isTuple name -> toTuple args

141−

142− T.App _ _ ->

143− error "decode: bad union type"

144−

145− T.Record _ (Just _) ->

146− error "decode: bad record"

147−

148− T.Record fields Nothing ->

149− toRecord fields

150−

151−

152−-- DECODE HELPERS

153−

154−

155−to :: Text -> Opt.Expr

156−to name =

157− Opt.VarGlobal (Var.Global jsonDecode name)

158−

159−

160−jsonDecode :: ModuleName.Canonical

161−jsonDecode =

162− ModuleName.inCore "Json.Decode"

163−

164−

165−field :: Text -> Opt.Expr -> Opt.Expr

166−field name decoder =

167− to "field" <== [ Opt.Literal (Literal.Str name), decoder ]

168−

169−

170−index :: Int -> Opt.Expr -> Opt.Expr

171−index i decoder =

172− to "index" <== [ Opt.Literal (Literal.IntNum i), decoder ]

173−

174−

175−(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr

176−(<==) func args =

177− Opt.Call func args

178−

179−

180−

181−-- COMPLEX DECODE HELPERS

182−

183−

184−toMaybe :: T.Canonical -> Opt.Expr

185−toMaybe tipe =

186− let

187− maybe tag =

188− Opt.VarGlobal (Var.Global (ModuleName.inCore "Maybe") tag)

189− in

190− to "oneOf" <==

191− [ Opt.List

192− [ to "null" <== [ maybe "Nothing" ]

193− , to "map" <== [ maybe "Just", decode tipe ]

194− ]

195− ]

196−

197−

198−toTuple0 :: Opt.Expr

199−toTuple0 =

200− to "null" <== [ Opt.Ctor "_Tuple0" [] ]

201−

202−

203−toTuple :: [T.Canonical] -> Opt.Expr

204−toTuple types =

205− let

206− size =

207− length types

208−

209− pairs =

210− zipWith (,) [ 0 .. size - 1] types

211−

212− toVar i =

213− Text.pack ('x' : show i)

214−

215− makeTuple =

216− to "succeed" <==

217− [ Opt.Ctor

218− (Text.pack ("_Tuple" ++ show size))

219− (map (Opt.VarLocal . toVar . fst) pairs)

220− ]

221−

222− andThen (i, tipe) decoder =

223− to "andThen" <== [ Opt.Function [toVar i] decoder, index i (decode tipe) ]

224− in

225− List.foldr andThen makeTuple pairs

226−

227−

228−toRecord :: [(Text, T.Canonical)] -> Opt.Expr

229−toRecord fields =

230− let

231− toFieldExpr (key, _) =

232− (key, Opt.VarLocal key)

233−

234− finalDecoder =

235− to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]

236−

237− andThen (key, tipe) decoder =

238− to "andThen" <== [ Opt.Function [key] decoder, field key (decode tipe) ]

239− in

240− List.foldr andThen finalDecoder fields

src/Optimize.hs+22−4

@@ -19,6 +19,7 @@ import qualified Optimize.Case as Case

19import qualified Optimize.DecisionTree as DT

20import qualified Optimize.Environment as Env

21import qualified Optimize.Inline as Inline

22+import qualified Optimize.Port as Port

22import qualified Reporting.Annotation as A

23import qualified Reporting.Annotation as A

23import qualified Reporting.Region as R

24import qualified Reporting.Region as R

@@ -281,13 +282,13 @@ optimizeExpr context annExpr@(A.A region expression) =

281 Opt.Sub home <$> Env.registerEffects home manager

282 Opt.Sub home <$> Env.registerEffects home manager

282

283

283 Can.OutgoingPort name tipe ->

284 Can.OutgoingPort name tipe ->

284− pure (Opt.OutgoingPort name tipe)

285+ Opt.OutgoingPort name <$> Port.toEncoder tipe

285

286

286 Can.IncomingPort name tipe ->

287 Can.IncomingPort name tipe ->

287− pure (Opt.IncomingPort name tipe)

288+ Opt.IncomingPort name <$> Port.toDecoder tipe

288

289

289− Can.Program kind expr ->

290+ Can.Program main expr ->

290− Opt.Program kind <$> justConvert expr

291+ Opt.Program <$> optimizeMain main <*> justConvert expr

291

292

292 Can.SaveEnv _ _ ->

293 Can.SaveEnv _ _ ->

293 error "save_the_environment should never make it to optimization phase"

294 error "save_the_environment should never make it to optimization phase"

@@ -326,6 +327,23 @@ optimizeVariable region (Var.Canonical home name) =

326

327

328

329

330+-- OPTIMIZE MAIN

331+

332+

333+optimizeMain :: Can.Main -> Env.Optimizer Opt.Main

334+optimizeMain main =

335+ case main of

336+ Can.VDom ->

337+ return Opt.VDom

338+

339+ Can.NoFlags ->

340+ return Opt.NoFlags

341+

342+ Can.Flags tipe ->

343+ Opt.Flags <$> Port.toDecoder tipe

344+

345+

346+

329-- OPTIMIZE CASE BRANCHES

347-- OPTIMIZE CASE BRANCHES

330

348

331

349

src/Optimize/Port.hsnew file+312

@@ -0,0 +1,312 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Optimize.Port

4+ ( toEncoder

5+ , toDecoder

6+ )

7+ where

10+import Prelude hiding (maybe, null)

11+import Control.Monad (foldM, zipWithM)

12+import qualified Data.Text as Text

13+import Data.Text (Text)

14+

15+import qualified AST.Expression.Optimized as Opt

16+import qualified AST.Literal as Literal

17+import qualified AST.Module.Name as ModuleName

18+import qualified AST.Type as T

19+import qualified AST.Variable as Var

20+import qualified Optimize.DecisionTree as DT

21+import qualified Optimize.Environment as Env

22+

23+

24+

25+-- ENCODE

26+

27+

28+toEncoder :: T.Canonical -> Env.Optimizer Opt.Expr

29+toEncoder tipe =

30+ case tipe of

31+ T.Aliased _ args t ->

32+ toEncoder (T.dealias args t)

33+

34+ T.Lambda _ _ ->

35+ error "toEncoder: function"

36+

37+ T.Var _ ->

38+ error "toEncoder: type variable"

39+

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"

48+

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"

54+

55+ T.App (T.Type name) args

56+ | Var.isTuple name -> encodeTuple args

57+

58+ T.App _ _ ->

59+ error "toEncoder: bad union type"

60+

61+ T.Record _ (Just _) ->

62+ error "toEncoder: bad record"

63+

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)

75+

76+

77+

78+-- ENCODE HELPERS

79+

80+

81+encodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr

82+encodeMaybe tipe =

83+ do null <- encode "null"

84+ encoder <- toEncoder tipe

85+

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)

90+

91+ return $ Opt.Function ["m"] $

92+ Opt.Case "m" (Opt.Chain [test] (leaf null) (leaf just)) []

93+

94+

95+encodeList :: T.Canonical -> Env.Optimizer Opt.Expr

96+encodeList 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" ] ]

103+

104+

105+encodeArray :: T.Canonical -> Env.Optimizer Opt.Expr

106+encodeArray 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" ] ]

113+

114+

115+encodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr

116+encodeTuple 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

126+

127+

128+

129+-- DECODE

130+

131+

132+toDecoder :: T.Canonical -> Env.Optimizer Opt.Expr

133+toDecoder tipe =

134+ case tipe of

135+ T.Lambda _ _ ->

136+ error "functions should not be allowed through input ports"

137+

138+ T.Var _ ->

139+ error "type variables should not be allowed through input ports"

140+

141+ T.Aliased _ args t ->

142+ toDecoder (T.dealias args t)

143+

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"

152+

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"

158+

159+ T.App (T.Type name) args

160+ | Var.isTuple name -> decodeTuple args

161+

162+ T.App _ _ ->

163+ error "toDecoder: bad union type"

164+

165+ T.Record _ (Just _) ->

166+ error "toDecoder: bad record"

167+

168+ T.Record fields Nothing ->

169+ decodeRecord fields

170+

171+

172+

173+-- DECODE MAYBE

174+

175+

176+decodeMaybe :: T.Canonical -> Env.Optimizer Opt.Expr

177+decodeMaybe tipe =

178+ do let nothing = Var.Global (ModuleName.inCore "Maybe") "Nothing"

179+ let just = Var.Global (ModuleName.inCore "Maybe") "Just"

180+

181+ Env.register nothing

182+ Env.register just

183+

184+ oneOf <- decode "oneOf"

185+ null <- decode "null"

186+ map_ <- decode "map"

187+

188+ subDecoder <- toDecoder tipe

189+

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+ ]

197+

198+

199+-- DECODE LIST

200+

201+

202+decodeList :: T.Canonical -> Env.Optimizer Opt.Expr

203+decodeList tipe =

204+ do list <- decode "list"

205+ decoder <- toDecoder tipe

206+ return $ Opt.Call list [ decoder ]

207+

208+

209+

210+-- DECODE ARRAY

211+

212+

213+decodeArray :: T.Canonical -> Env.Optimizer Opt.Expr

214+decodeArray tipe =

215+ do array <- decode "array"

216+ decoder <- toDecoder tipe

217+ return $ Opt.Call array [ decoder ]

218+

219+

220+

221+-- DECODE TUPLES

222+

223+

224+decodeTuple0 :: Env.Optimizer Opt.Expr

225+decodeTuple0 =

226+ do null <- decode "null"

227+ return (Opt.Call null [ Opt.Ctor "_Tuple0" [] ])

228+

229+

230+decodeTuple :: [T.Canonical] -> Env.Optimizer Opt.Expr

231+decodeTuple types =

232+ let

233+ size =

234+ length types

235+

236+ entries =

237+ zip [ 0 .. size - 1] types

238+

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

246+

247+

248+indexToName :: Int -> Text

249+indexToName index =

250+ Text.pack ('x' : show index)

251+

252+

253+indexAndThen :: Opt.Expr -> (Int, T.Canonical) -> Env.Optimizer Opt.Expr

254+indexAndThen 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+ ]

263+

264+

265+

266+-- DECODE RECORDS

267+

268+

269+decodeRecord :: [(Text, T.Canonical)] -> Env.Optimizer Opt.Expr

270+decodeRecord fields =

271+ let

272+ toFieldExpr (key, _) =

273+ (key, Opt.VarLocal key)

274+

275+ record =

276+ Opt.Record (map toFieldExpr fields)

277+ in

278+ do succeed <- decode "succeed"

279+ foldM fieldAndThen (Opt.Call succeed [record]) fields

280+

281+

282+fieldAndThen :: Opt.Expr -> (Text, T.Canonical) -> Env.Optimizer Opt.Expr

283+fieldAndThen 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+ ]

292+

293+

294+

295+-- GLOBALS HELPERS

296+

297+

298+core :: Text -> Text -> Env.Optimizer Opt.Expr

299+core home name =

300+ do let var = Var.Global (ModuleName.inCore home) name

301+ Env.register var

302+ return (Opt.VarGlobal var)

303+

304+

305+encode :: Text -> Env.Optimizer Opt.Expr

306+encode name =

307+ core "Json.Encode" name

308+

309+

310+decode :: Text -> Env.Optimizer Opt.Expr

311+decode name =

312+ core "Json.Decode" name