ba0b721 · elk · git.iko.soy

git.iko.soy/elk

Merge Nitpick.TopLevelTypes into Optimize.Module

I do not really like this, but I need the dependency and field information from generating the JSON decoder for programs. This seems like the least crappy way of handling it.

commitba0b721d12dc92081a8919238827dc0a9f530d50 authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 26 Jan 2018, 20:54 (9 years ago) parente76858c

6 files changed+175−222

compare with master

unifiedsplit

elm-compiler.cabal−1 src/AST/Optimized.hs+2−2 src/Compile.hs+3−6 src/Generate/JavaScript/Expression.hs+1−1 src/Nitpick/TopLevelTypes.hs−111 src/Optimize/Module.hs+169−101

elm-compiler.cabal−1

@@ -93,7 +93,6 @@ Library

9393 Generate.JavaScript.Name,

9494 Json.Decode.Internals,

9595 Nitpick.PatternMatches,

96− Nitpick.TopLevelTypes,

9796 Optimize.Case,

9897 Optimize.DecisionTree,

9998 Optimize.Expression,

src/AST/Optimized.hs+2−2

@@ -138,8 +138,8 @@ data Graph =

138138data Main

139139 = Static

140140 | Dynamic

141− { _decoder :: Expr

142− , _message :: Can.Type

141+ { _message :: Can.Type

142+ , _decoder :: Expr

143143 }

144144

145145

src/Compile.hs+3−6

@@ -19,7 +19,6 @@ import qualified Elm.Interface as I

1919import qualified Elm.Name as N

2020import qualified Elm.Package as Pkg

2121import qualified Nitpick.PatternMatches as PatternMatches

22−import qualified Nitpick.TopLevelTypes as TopLevelTypes

2322import qualified Optimize.Module as Optimize

2423import qualified Parse.Parse as Parse

2524import qualified Reporting.Error as Error

@@ -63,13 +62,11 @@ compile flag pkg importDict interfaces source =

6362 annotations <-

6463 runTypeInference canonical

6564

66− mains <- Result.mapError Error.Main $

67− TopLevelTypes.check annotations canonical

68−

6965 () <-

7066 exhaustivenessCheck canonical

7167

72− let (Optimize.Graph fields graph) = Optimize.optimize canonical

68+ graph <- Result.mapError Error.Main $

69+ Optimize.optimize annotations canonical

7370

7471 documentation <-

7572 genaretaDocs flag canonical

@@ -77,7 +74,7 @@ compile flag pkg importDict interfaces source =

7774 Result.ok $

7875 Artifacts

7976 { _elmi = I.fromModule annotations canonical

80− , _elmo = Opt.Graph mains graph fields

77+ , _elmo = graph

8178 , _docs = documentation

8279 }

8380

src/Generate/JavaScript/Expression.hs+1−1

@@ -1006,7 +1006,7 @@ generateMain mode interfaces home main =

10061006 # JS.Int 0

10071007 # JS.Int 0

10081008

1009− Opt.Dynamic decoder msgType ->

1009+ Opt.Dynamic msgType decoder ->

10101010 JS.Ref (Name.fromGlobal home "main")

10111011 # generateJsExpr mode decoder

10121012 # toDebugMetadata mode interfaces msgType

src/Nitpick/TopLevelTypes.hsdeleted−111

@@ -1,111 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Nitpick.TopLevelTypes

4− ( check

5− )

6− where

7−

8−

9−import Control.Monad (foldM)

10−import qualified Data.Map as Map

11−import Data.Map ((!))

12−

13−import qualified AST.Canonical as Can

14−import qualified AST.Optimized as Opt

15−import qualified AST.Module.Name as ModuleName

16−import qualified AST.Utils.Type as Type

17−import qualified Canonicalize.Effects as Effects

18−import qualified Elm.Name as N

19−import qualified Optimize.Names as Names

20−import qualified Optimize.Port as Port

21−import qualified Reporting.Annotation as A

22−import qualified Reporting.Error.Main as Error

23−import qualified Reporting.Region as R

24−import qualified Reporting.Result as Result

25−import qualified Reporting.Warning as W

26−

27−

28−

29−-- CHECK TOP-LEVEL TYPES

30−

31−

32−type Result i w a =

33− Result.Result i w Error.Error a

34−

35−

36−type Annotations =

37− Map.Map N.Name Can.Annotation

38−

39−

40−type Mains =

41− Map.Map ModuleName.Canonical Opt.Main

42−

43−

44−check :: Annotations -> Can.Module -> Result i [W.Warning] Mains

45−check annotations (Can.Module home _ _ decls _ _ _ _) =

46− checkDecls home annotations decls Map.empty

47−

48−

49−checkDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Mains -> Result i [W.Warning] Mains

50−checkDecls home annotations decls mains =

51− case decls of

52− Can.Declare def subDecls ->

53− checkDecls home annotations subDecls =<<

54− checkDef home annotations mains def

55−

56− Can.DeclareRec defs subDecls ->

57− checkDecls home annotations subDecls =<<

58− foldM (checkDef home annotations) mains defs

59−

60− Can.SaveTheEnvironment ->

61− Result.ok mains

62−

63−

64−

65−-- MISSING ANNOTATIONS

66−

67−

68−checkDef :: ModuleName.Canonical -> Annotations -> Mains -> Can.Def -> Result i [W.Warning] Mains

69−checkDef home annotations mains def =

70− case def of

71− Can.Def (A.At region name) _ _ ->

72− do let (Can.Forall _ annotation) = annotations ! name

73− Result.warn $ W.MissingTypeAnnotation region name annotation

74− checkMain region annotations home name mains

75−

76− Can.TypedDef (A.At region name) _ _ _ _ ->

77− checkMain region annotations home name mains

78−

79−

80−

81−-- CHECK MAIN TYPE

82−

83−

84−checkMain :: R.Region -> Annotations -> ModuleName.Canonical -> N.Name -> Mains -> Result i w Mains

85−checkMain region annotations home name mains =

86− if name == N.main then

87− do mainType <- checkMainType region (annotations ! name)

88− Result.ok $ Map.insert home mainType mains

89− else

90− Result.ok mains

91−

92−

93−checkMainType :: R.Region -> Can.Annotation -> Result i w Opt.Main

94−checkMainType region (Can.Forall _ tipe) =

95− case Type.deepDealias tipe of

96− Can.TType home name [_]

97− | home == ModuleName.virtualDom && name == N.node ->

98− Result.ok Opt.Static

99−

100− Can.TType home name [flags, message, _]

101− | home == ModuleName.platform && name == N.program ->

102− case Effects.checkPayload flags of

103− Left (subType, invalidPayload) ->

104− Result.throw (Error.BadFlags region subType invalidPayload)

105−

106− Right () ->

107− let (_, _, flagDecoder) = Names.run (Port.toFlagsDecoder flags) in

108− Result.ok (Opt.Dynamic flagDecoder message)

109−

110− _ ->

111− Result.throw (Error.BadType region tipe)

src/Optimize/Module.hs+169−101

@@ -1,8 +1,7 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Optimize.Module

4− ( Graph(..)

5− , optimize

4+ ( optimize

65 )

76 where

@@ -12,49 +11,56 @@ import Control.Monad (foldM)

1211import qualified Data.List as List

1312import qualified Data.Map as Map

1413import qualified Data.Set as Set

14+import Data.Map ((!))

1515

1616import qualified AST.Canonical as Can

1717import qualified AST.Optimized as Opt

1818import qualified AST.Module.Name as ModuleName

19+import qualified AST.Utils.Type as Type

20+import qualified Canonicalize.Effects as Effects

1921import qualified Elm.Name as N

2022import qualified Optimize.Expression as Expr

2123import qualified Optimize.Names as Names

2224import qualified Optimize.Port as Port

2325import qualified Reporting.Annotation as A

26+import qualified Reporting.Error.Main as E

27+import qualified Reporting.Region as R

28+import qualified Reporting.Result as Result

29+import qualified Reporting.Warning as W

2430

2531

2632

2733-- OPTIMIZE

2834

2935

30−data Graph =

31− Graph

32− { _fields :: Map.Map N.Name Int

33− , _nodes :: Nodes

34− }

36+type Result i w a =

37+ Result.Result i w E.Error a

3538

3639

37−type Nodes =

38− Map.Map Opt.Global Opt.Node

40+type Annotations =

41+ Map.Map N.Name Can.Annotation

3942

4043

41−optimize :: Can.Module -> Graph

42−optimize (Can.Module home _ _ decls unions aliases _ effects) =

43− addEffects home effects $

44− addUnions home unions $

45− addAliases home aliases $

46− addDecls home decls $

47− Graph Map.empty Map.empty

44+optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.Graph

45+optimize annotations (Can.Module home _ _ decls unions aliases _ effects) =

46+ addDecls home annotations decls $

47+ addEffects home effects $

48+ addUnions home unions $

49+ addAliases home aliases $

50+ Opt.Graph Map.empty Map.empty Map.empty

4851

4952

5053

5154-- UNION

5255

5356

54−addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Graph -> Graph

55−addUnions home unions (Graph fields nodes) =

56− Graph fields $

57− Map.foldr (addUnion home) nodes unions

57+type Nodes =

58+ Map.Map Opt.Global Opt.Node

59+

60+

61+addUnions :: ModuleName.Canonical -> Map.Map N.Name Can.Union -> Opt.Graph -> Opt.Graph

62+addUnions home unions (Opt.Graph mains nodes fields) =

63+ Opt.Graph mains (Map.foldr (addUnion home) nodes unions) fields

5864

5965

6066addUnion :: ModuleName.Canonical -> Can.Union -> Nodes -> Nodes

@@ -71,13 +77,13 @@ addCtorNode home nodes (Can.Ctor name index numArgs _) =

7177-- ALIAS

7278

7379

74−addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Graph -> Graph

80+addAliases :: ModuleName.Canonical -> Map.Map N.Name Can.Alias -> Opt.Graph -> Opt.Graph

7581addAliases home aliases graph =

7682 Map.foldrWithKey (addAlias home) graph aliases

7783

7884

79−addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Graph -> Graph

80−addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =

85+addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph

86+addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph mains nodes fieldCounts) =

8187 case maybeFields of

8288 Nothing ->

8389 graph

@@ -91,9 +97,10 @@ addAlias home name (Can.Alias _ _ maybeFields) graph@(Graph fieldCounts nodes) =

9197 node =

9298 Opt.Define function Set.empty

9399 in

94− Graph

95− (foldr addOne fieldCounts fields)

100+ Opt.Graph

101+ mains

96102 (Map.insert (Opt.Global home name) node nodes)

103+ (foldr addOne fieldCounts fields)

97104

98105

99106toPair :: N.Name -> (N.Name, Opt.Expr)

@@ -110,8 +117,8 @@ addOne name fields =

110117-- ADD EFFECTS

111118

112119

113−addEffects :: ModuleName.Canonical -> Can.Effects -> Graph -> Graph

114−addEffects home effects graph@(Graph fields nodes) =

120+addEffects :: ModuleName.Canonical -> Can.Effects -> Opt.Graph -> Opt.Graph

121+addEffects home effects graph@(Opt.Graph mains nodes fields) =

115122 case effects of

116123 Can.NoEffects ->

117124 graph

@@ -120,30 +127,30 @@ addEffects home effects graph@(Graph fields nodes) =

120127 Map.foldrWithKey (addPort home) graph ports

121128

122129 Can.Manager _ _ _ manager ->

123− Graph fields $

124− let

125− fx = Opt.Global home "$fx$"

126− cmd = Opt.Global home "command"

127− sub = Opt.Global home "subscription"

128− link = Opt.Link fx

129− in

130− case manager of

131− Can.Cmd _ ->

132− Map.insert cmd link $

133− Map.insert fx (Opt.Manager Opt.Cmd) nodes

134−

135− Can.Sub _ ->

136− Map.insert sub link $

137− Map.insert fx (Opt.Manager Opt.Sub) nodes

138−

139− Can.Fx _ _ ->

140− Map.insert cmd link $

141− Map.insert sub link $

142− Map.insert fx (Opt.Manager Opt.Fx) nodes

143−

130+ let

131+ fx = Opt.Global home "$fx$"

132+ cmd = Opt.Global home "command"

133+ sub = Opt.Global home "subscription"

134+ link = Opt.Link fx

135+ newNodes =

136+ case manager of

137+ Can.Cmd _ ->

138+ Map.insert cmd link $

139+ Map.insert fx (Opt.Manager Opt.Cmd) nodes

140+

141+ Can.Sub _ ->

142+ Map.insert sub link $

143+ Map.insert fx (Opt.Manager Opt.Sub) nodes

144+

145+ Can.Fx _ _ ->

146+ Map.insert cmd link $

147+ Map.insert sub link $

148+ Map.insert fx (Opt.Manager Opt.Fx) nodes

149+ in

150+ Opt.Graph mains newNodes fields

144151

145152

146−addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Graph -> Graph

153+addPort :: ModuleName.Canonical -> N.Name -> Can.Port -> Opt.Graph -> Opt.Graph

147154addPort home name port_ graph =

148155 case port_ of

149156 Can.Incoming _ payloadType _ ->

@@ -162,86 +169,151 @@ addPort home name port_ graph =

162169

163170

164171

172+-- HELPER

173+

174+

175+addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Opt.Graph -> Opt.Graph

176+addToGraph name node fields (Opt.Graph mains nodes fieldCounts) =

177+ Opt.Graph

178+ mains

179+ (Map.insert name node nodes)

180+ (Map.unionWith (+) fields fieldCounts)

181+

182+

183+

165184-- ADD DECLS

166185

167186

168−addDecls :: ModuleName.Canonical -> Can.Decls -> Graph -> Graph

169−addDecls home decls graph =

187+addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.Graph -> Result i [W.Warning] Opt.Graph

188+addDecls home annotations decls graph =

170189 case decls of

171190 Can.Declare def subDecls ->

172− addDecls home subDecls (addDef home def graph)

191+ addDecls home annotations subDecls =<< addDef home annotations def graph

173192

174193 Can.DeclareRec defs subDecls ->

175− addDecls home subDecls (addRecDefs home defs graph)

194+ case findMain defs of

195+ Nothing ->

196+ addDecls home annotations subDecls (addRecDefs home defs graph)

197+

198+ Just region ->

199+ Result.throw $ E.BadCycle region (map defToName defs)

176200

177201 Can.SaveTheEnvironment ->

178− graph

202+ Result.ok graph

203+

204+

205+findMain :: [Can.Def] -> Maybe R.Region

206+findMain defs =

207+ case defs of

208+ [] ->

209+ Nothing

210+

211+ def:rest ->

212+ case def of

213+ Can.Def (A.At region name) _ _ ->

214+ if name == N.main then Just region else findMain rest

215+

216+ Can.TypedDef (A.At region name) _ _ _ _ ->

217+ if name == N.main then Just region else findMain rest

218+

219+

220+defToName :: Can.Def -> N.Name

221+defToName def =

222+ case def of

223+ Can.Def (A.At _ name) _ _ -> name

224+ Can.TypedDef (A.At _ name) _ _ _ _ -> name

179225

180226

181227

182228-- ADD DEFS

183229

184230

185−addDef :: ModuleName.Canonical -> Can.Def -> Graph -> Graph

186−addDef home def graph =

231+addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.Graph -> Result i [W.Warning] Opt.Graph

232+addDef home annotations def graph =

187233 case def of

188− Can.Def (A.At _ name) args body ->

189− addDefHelp (Opt.Global home name) args body graph

234+ Can.Def (A.At region name) args body ->

235+ do let (Can.Forall _ tipe) = annotations ! name

236+ Result.warn $ W.MissingTypeAnnotation region name tipe

237+ addDefHelp region annotations home name args body graph

190238

191− Can.TypedDef (A.At _ name) _ typedArgs body _ ->

192− addDefHelp (Opt.Global home name) (map fst typedArgs) body graph

239+ Can.TypedDef (A.At region name) _ typedArgs body _ ->

240+ addDefHelp region annotations home name (map fst typedArgs) body graph

193241

194242

195−addDefHelp :: Opt.Global -> [Can.Pattern] -> Can.Expr -> Graph -> Graph

196−addDefHelp name args body graph =

197− case args of

198− [] ->

199− let

200− (deps, fields, value) =

201− Names.run (Expr.optimize Set.empty body)

202− in

203− addToGraph name (Opt.Define value deps) fields graph

243+addDefHelp :: R.Region -> Annotations -> ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Opt.Graph -> Result i w Opt.Graph

244+addDefHelp region annotations home name args body graph@(Opt.Graph mains nodes fieldCounts) =

245+ if name /= N.main then

246+ Result.ok (addDefNode home name args body Set.empty graph)

247+ else

248+ let

249+ (Can.Forall _ tipe) = annotations ! name

204250

205− _ ->

206− let

207− (deps, fields, function) =

208− Names.run $

251+ addMain (deps, fields, main) =

252+ let

253+ newMains = Map.insert home main mains

254+ newFields = Map.unionWith (+) fields fieldCounts

255+ in

256+ addDefNode home name args body deps $

257+ Opt.Graph newMains nodes newFields

258+ in

259+ case Type.deepDealias tipe of

260+ Can.TType hm nm [_] | hm == ModuleName.virtualDom && nm == N.node ->

261+ Result.ok $ addMain $ Names.run $

262+ Names.registerKernel N.browser Opt.Static

263+

264+ Can.TType hm nm [flags, message, _] | hm == ModuleName.platform && nm == N.program ->

265+ case Effects.checkPayload flags of

266+ Right () ->

267+ Result.ok $ addMain $ Names.run $

268+ Opt.Dynamic message <$> Port.toFlagsDecoder flags

269+

270+ Left (subType, invalidPayload) ->

271+ Result.throw (E.BadFlags region subType invalidPayload)

272+

273+ _ ->

274+ Result.throw (E.BadType region tipe)

275+

276+

277+addDefNode :: ModuleName.Canonical -> N.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.Graph -> Opt.Graph

278+addDefNode home name args body mainDeps graph =

279+ let

280+ (deps, fields, def) =

281+ Names.run $

282+ case args of

283+ [] ->

284+ Expr.optimize Set.empty body

285+

286+ _ ->

209287 do (argNames, destructors) <- Expr.destructArgs args

210288 obody <- Expr.optimize Set.empty body

211289 pure $ Opt.Function argNames $

212290 foldr Opt.Destruct obody destructors

213− in

214− addToGraph name (Opt.Define function deps) fields graph

291+ in

292+ addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph

215293

216294

217−addToGraph :: Opt.Global -> Opt.Node -> Map.Map N.Name Int -> Graph -> Graph

218−addToGraph name node fields (Graph fieldCounts nodes) =

219− Graph

220− (Map.unionWith (+) fields fieldCounts)

221− (Map.insert name node nodes)

222295

296+-- ADD RECURSIVE DEFS

223297

224298

225−-- ADD RECURSIVE DEFS

299+data State =

300+ State

301+ { _values :: [(N.Name, Opt.Expr)]

302+ , _graph :: Opt.Graph

303+ }

226304

227305

228−addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Graph -> Graph

306+addRecDefs :: ModuleName.Canonical -> [Can.Def] -> Opt.Graph -> Opt.Graph

229307addRecDefs home defs graph =

230308 let

231− cycleValues =

232− foldr addValueName Set.empty defs

233−

234− dummyName =

235− Opt.Global home (N.toCompositeName cycleValues)

309+ cycleValues = foldr addValueName Set.empty defs

310+ dummyName = Opt.Global home (N.toCompositeName cycleValues)

236311

237312 (deps, fields, State cyclicValuePairs newGraph) =

238313 Names.run $

239314 foldM (addRecDef home dummyName cycleValues) (State [] graph) defs

240−

241− node =

242− Opt.Cycle cyclicValuePairs deps

243315 in

244− addToGraph dummyName node fields newGraph

316+ addToGraph dummyName (Opt.Cycle cyclicValuePairs deps) fields newGraph

245317

246318

247319addValueName :: Can.Def -> Set.Set N.Name -> Set.Set N.Name

@@ -261,13 +333,6 @@ addValueName def valueNames =

261333-- ADD RECURSIVE DEFS

262334

263335

264−data State =

265− State

266− { _values :: [(N.Name, Opt.Expr)]

267− , _graph :: Graph

268− }

269−

270−

271336addRecDef :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> State -> Can.Def -> Names.Tracker State

272337addRecDef home dummyName cycle state@(State values graph) def =

273338 case def of

@@ -294,11 +359,14 @@ addRecDef home dummyName cycle state@(State values graph) def =

294359

295360

296361addRecValue :: ModuleName.Canonical -> Opt.Global -> Expr.Cycle -> N.Name -> Can.Expr -> State -> Names.Tracker State

297−addRecValue home dummyName cycle name body (State values (Graph fields nodes)) =

362+addRecValue home dummyName cycle name body (State values (Opt.Graph mains nodes fields)) =

298363 do obody <- Expr.optimize cycle body

364+

365+ let global = Opt.Global home name

366+ let node = Opt.Link dummyName

367+

299368 pure $

300369 State

301370 { _values = (name, obody) : values

302− , _graph = Graph fields $

303− Map.insert (Opt.Global home name) (Opt.Link dummyName) nodes

371+ , _graph = Opt.Graph mains (Map.insert global node nodes) fields

304372 }