247359c · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Make code gen of `main` values easier

247359cEvan Czaplicki9 years ago

src/AST/Optimized.hs+7−4

compare with master

unifiedsplit

@@ -121,7 +121,10 @@ data Graph =

121

122data Main

123 = Static

124− | Dynamic Can.Type

124+ | Dynamic

125+ { _decoder :: Expr

126+ , _message :: Can.Type

127+ }

125

128

126

129

127data Node

130data Node

@@ -274,14 +277,14 @@ instance Binary Graph where

274instance Binary Main where

277instance Binary Main where

275 put main =

278 put main =

276 case main of

279 case main of

277− Static -> putWord8 0

280+ Static -> putWord8 0

278− Dynamic a -> putWord8 1 >> put a

281+ Dynamic a b -> putWord8 1 >> put a >> put b

279

282

280 get =

283 get =

281 do word <- getWord8

284 do word <- getWord8

282 case word of

285 case word of

283 0 -> return Static

286 0 -> return Static

284− 1 -> liftM Dynamic get

287+ 1 -> liftM2 Dynamic get get

285 _ -> error "problem getting Opt.Main binary"

288 _ -> error "problem getting Opt.Main binary"

286

289

287

290

src/Elm/Compiler/Module.hs−6

@@ -5,7 +5,6 @@ module Elm.Compiler.Module

5 ( I.Interface

6 , I.Interfaces

7 , interfaceAliasedTypes

8− , programTypes

10 -- module names

9 -- module names

11 , Raw

10 , Raw

@@ -46,11 +45,6 @@ interfaceAliasedTypes interface =

46 Map.map Extract.fromAnnotation (I._types interface)

45 Map.map Extract.fromAnnotation (I._types interface)

49−programTypes :: I.Interfaces -> ModuleName.Canonical -> Maybe Type.Program

50−programTypes =

51− Extract.fromProgram

52−

53−

55-- NAMES

49-- NAMES

src/Elm/Compiler/Objects.hs+7−21

@@ -1,11 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2module Elm.Compiler.Objects

3− ( JS.Mode(..)

4− , Name.Target(..)

3+ ( Name.Target(..)

5− , JS.generate

4+ , JS.ReplBuilder(..)

6− , JS.Roots

5+ , JS.generateForRepl

7− , mains

6+ , JS.Mode(..)

8− , value

7+ , JS.MainsBuilder(..)

8+ , JS.MainTrie(..)

9+ , JS.generateMains

9 , Opt.Graph

10 , Opt.Graph

10 , empty

11 , empty

11 , union

12 , union

@@ -16,7 +17,6 @@ module Elm.Compiler.Objects

18import qualified Data.Map as Map

19import qualified Data.Map as Map

19−import qualified Data.Text as Text

21import qualified AST.Optimized as Opt

22import qualified AST.Module.Name as ModuleName

@@ -27,20 +27,6 @@ import qualified Generate.JavaScript.Name as Name

30−-- ROOTS

31−

32−

33−mains :: [ModuleName.Canonical] -> JS.Roots

34−mains =

35− JS.Mains

36−

37−

38−value :: ModuleName.Canonical -> String -> JS.Roots

39−value home name =

40− JS.Value home (Text.pack name)

41−

42−

43−

44-- COMBINE GRAPHS

30-- COMBINE GRAPHS

src/Elm/Compiler/Type.hs+6−6

@@ -4,12 +4,12 @@ module Elm.Compiler.Type

4 ( Type(..)

5 , Format(..)

6 , toString

7− , Program(..)

7+ , DebugMetadata(..)

8 , Alias(..)

9 , Union(..)

10 , encode

11 , decoder

12− , encodeProgram

12+ , encodeMetadata

13 )

14 where

@@ -43,8 +43,8 @@ data Type

43 | Tuple Type Type [Type]

46−data Program =

46+data DebugMetadata =

47− Program

47+ DebugMetadata

48 { _message :: Type

49 , _aliases :: [Alias]

50 , _unions :: [Union]

@@ -230,8 +230,8 @@ fromRawType (A.At _ astType) =

230-- JSON for PROGRAM

231

232

233−encodeProgram :: Program -> Encode.Value

233+encodeMetadata :: DebugMetadata -> Encode.Value

234−encodeProgram (Program msg aliases unions) =

234+encodeMetadata (DebugMetadata msg aliases unions) =

235 Encode.object

236 [ "message" ==> encode msg

237 , "aliases" ==> Encode.object (map toAliasField aliases)

src/Elm/Compiler/Type/Extract.hs+10−22

@@ -4,7 +4,7 @@

4module Elm.Compiler.Type.Extract

5 ( fromAnnotation

6 , fromType

7− , fromProgram

7+ , fromMsg

8 )

9 where

@@ -83,28 +83,16 @@ toPublicName (ModuleName.Canonical _ home) name =

83-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES

86−fromProgram :: I.Interfaces -> ModuleName.Canonical -> Maybe T.Program

86+fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata

87−fromProgram interfaces name =

87+fromMsg interfaces message =

88− do iface <- Map.lookup name interfaces

88+ let

89− mainType <- Map.lookup "main" (I._types iface)

89+ (msgDeps, msgType) =

90− message <- getMessage mainType

91−

92− let (msgDeps, msgType) = run (extract message)

90+ run (extract message)

93− let (aliases, unions) = extractTransitive interfaces noDeps msgDeps

94− Just (T.Program msgType aliases unions)

95−

96−

97−getMessage :: Can.Annotation -> Maybe Can.Type

98−getMessage (Can.Forall _ mainType) =

99− case Type.deepDealias mainType of

100− Can.TType _ _program [_flags, _model, msg] ->

101− Just msg

102−

103− Can.TType _ _node [msg] ->

104− Just msg

105

106− _ ->

92+ (aliases, unions) =

107− Nothing

93+ extractTransitive interfaces noDeps msgDeps

94+ in

95+ T.DebugMetadata msgType aliases unions

108

109

110extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )

98extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )

src/Elm/Name.hs+6−1

@@ -10,7 +10,7 @@ module Elm.Name

10 , toCompositeName

11 , int, float, bool, char, string

12 , maybe, list, array, tuple

13− , task, router, cmd, sub, platform

13+ , task, router, cmd, sub, platform, browser

14 , shader, debug, bitwise, basics

15 , utils, negate, value

16 , node, program, main, dollar

@@ -137,6 +137,11 @@ platform :: Name

137platform = "Platform"

138

139

140+{-# NOINLINE browser #-}

141+browser :: Name

142+browser = "Browser"

143+

144+

140{-# NOINLINE shader #-}

145{-# NOINLINE shader #-}

141shader :: Name

146shader :: Name

142shader = "Shader"

147shader = "Shader"

src/Generate/JavaScript.hs+104−42

@@ -1,9 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2{-# LANGUAGE OverloadedStrings #-}

3module Generate.JavaScript

4+ ( ReplBuilder(..)

5+ , generateForRepl

4− ( Mode(..)

6+ , Mode(..)

5− , Roots(..)

7+ , MainsBuilder(..)

6− , generate

8+ , MainTrie(..)

9+ , generateMains

7 )

10 )

8 where

11 where

@@ -15,9 +18,11 @@ import qualified Data.List as List

15import Data.Map ((!))

18import Data.Map ((!))

16import qualified Data.Map as Map

19import qualified Data.Map as Map

17import qualified Data.Set as Set

20import qualified Data.Set as Set

21+import qualified Data.Text as Text

19import qualified AST.Optimized as Opt

23import qualified AST.Optimized as Opt

20import qualified AST.Module.Name as ModuleName

24import qualified AST.Module.Name as ModuleName

25+import qualified Elm.Interface as I

21import qualified Elm.Name as N

26import qualified Elm.Name as N

22import qualified Generate.JavaScript.Builder as JS

27import qualified Generate.JavaScript.Builder as JS

23import qualified Generate.JavaScript.Expression as Expr

28import qualified Generate.JavaScript.Expression as Expr

@@ -25,27 +30,62 @@ import qualified Generate.JavaScript.Name as Name

28−-- GENERATE

33+-- GENERATE FOR REPL

34+

35+

36+data ReplBuilder =

37+ ReplBuilder

38+ { _repl_code :: B.Builder

39+ , _repl_name :: B.Builder

40+ }

41+

42+

43+generateForRepl :: Opt.Graph -> ModuleName.Canonical -> N.Name -> ReplBuilder

44+generateForRepl (Opt.Graph _ graph _) home name =

45+ ReplBuilder

46+ { _repl_code =

47+ stateToBuilder $

48+ addGlobal (Name.Debug Name.Client) graph emptyState (Opt.Global home name)

49+ , _repl_name =

50+ Name.toBuilder (Name.fromGlobal home name)

51+ }

52+

53+

54+

55+-- GENERATE MAINS

56+

57+

58+data MainsBuilder =

59+ MainsBuilder

60+ { _main_code :: B.Builder

61+ , _main_trie :: MainTrie

62+ }

31data Mode = Debug | Prod

65data Mode = Debug | Prod

34−data Roots

68+generateMains :: Mode -> Name.Target -> Opt.Graph -> I.Interfaces -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] MainsBuilder

35− = Mains [ModuleName.Canonical]

69+generateMains mode target (Opt.Graph mains graph fields) interfaces roots =

36− | Value ModuleName.Canonical N.Name

70+ let

71+ rootSet = Set.fromList roots

72+ rootMap = Map.restrictKeys mains rootSet

73+ in

74+ if Map.size rootMap == Set.size rootSet then

75+ let

76+ realMode = toRealMode mode target fields

77+ state = Map.foldrWithKey (addMain realMode graph) emptyState rootMap

78+ in

79+ Right $ MainsBuilder (stateToBuilder state) (toMainTrie realMode interfaces rootMap)

81+ else

82+ Left $ Set.toList $

83+ Set.intersection rootSet (Map.keysSet mains)

39−generate :: Mode -> Name.Target -> Opt.Graph -> Roots -> Either [ModuleName.Canonical] B.Builder

40−generate mode target (Opt.Graph mains nodes fields) roots =

41− case roots of

42− Value home name ->

43− Right $ stateToBuilder $

44− addGlobal (toRealMode mode target fields) nodes emptyState (Opt.Global home name)

46− Mains modules ->

86+addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State

47− generateMain (toRealMode mode target fields) nodes

87+addMain mode graph home _ state =

48− <$> verifyMains mains modules

88+ addGlobal mode graph state (Opt.Global home "main")

51toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode

91toRealMode :: Mode -> Name.Target -> Map.Map N.Name Int -> Name.Mode

@@ -327,39 +367,61 @@ generateManagerHelp home effectsType =

327

367

328

368

329

369

330−-- ADD MAIN

370+-- MAIN TRIE

331

371

332

372

333−type Mains =

373+data MainTrie =

334− Map.Map ModuleName.Canonical Opt.Main

374+ MainTrie

335−

375+ { _main :: Maybe B.Builder

376+ , _subs :: Map.Map N.Name MainTrie

377+ }

336

378

337−generateMain :: Name.Mode -> Graph -> Mains -> B.Builder

338−generateMain mode graph mains =

339− mconcat

340− [ stateToBuilder $ Map.foldrWithKey (addMain mode graph) emptyState mains

341− , exportMains mains

342− ]

343

379

380+emptyTrie :: MainTrie

381+emptyTrie =

382+ MainTrie Nothing Map.empty

344

383

345−addMain :: Name.Mode -> Graph -> ModuleName.Canonical -> main -> State -> State

346−addMain mode graph home _ state =

347− addGlobal mode graph state (Opt.Global home "main")

348

384

385+toMainTrie :: Name.Mode -> I.Interfaces -> Map.Map ModuleName.Canonical Opt.Main -> MainTrie

386+toMainTrie mode interfaces mains =

387+ Map.foldrWithKey (addMainTrie mode interfaces) emptyTrie mains

349

388

350−exportMains :: Mains -> B.Builder

351−exportMains mains =

352− error "TODO" mains

353

389

354−

390+addMainTrie :: Name.Mode -> I.Interfaces -> ModuleName.Canonical -> Opt.Main -> MainTrie -> MainTrie

355−verifyMains :: Mains -> [ModuleName.Canonical] -> Either [ModuleName.Canonical] Mains

391+addMainTrie mode interfaces home@(ModuleName.Canonical _ moduleName) main trie =

356−verifyMains mains modules =

357 let

392 let

358− rootSet = Set.fromList modules

393+ segments = Text.splitOn "." moduleName

359− rootMap = Map.restrictKeys mains rootSet

394+ initMain = Expr.generateMain mode interfaces home segments main

395+ newTrie = segmentsToTrie segments (JS.exprToBuilder initMain)

360 in

396 in

361− if Map.size rootMap == Set.size rootSet then

397+ merge trie newTrie

362− Right rootMap

398+

363− else

399+

364− Left $ Set.toList $

400+segmentsToTrie :: [N.Name] -> B.Builder -> MainTrie

365− Set.intersection rootSet (Map.keysSet mains)

401+segmentsToTrie segments mainBuilder =

402+ case segments of

403+ [] ->

404+ MainTrie (Just mainBuilder) Map.empty

405+

406+ segment : otherSegments ->

407+ MainTrie Nothing (Map.singleton segment (segmentsToTrie otherSegments mainBuilder))

408+

409+

410+merge :: MainTrie -> MainTrie -> MainTrie

411+merge (MainTrie main1 subs1) (MainTrie main2 subs2) =

412+ MainTrie

413+ (checkedMerge main1 main2)

414+ (Map.unionWith merge subs1 subs2)

415+

416+

417+checkedMerge :: Maybe a -> Maybe a -> Maybe a

418+checkedMerge a b =

419+ case (a, b) of

420+ (Nothing, main) ->

421+ main

422+

423+ (main, Nothing) ->

424+ main

425+

426+ (Just _, Just _) ->

427+ error "cannot have two modules with the same name"

src/Generate/JavaScript/Builder.hs+5

@@ -20,6 +20,7 @@ import Data.ByteString.Builder as B

20import Data.Monoid ((<>))

21import qualified Generate.JavaScript.Name as Name

22import Generate.JavaScript.Name (Name)

23+import qualified Json.Encode as Json

@@ -32,6 +33,7 @@ data Expr

32 | Int Int

33 | Int Int

33 | Bool Bool

34 | Bool Bool

34 | Null

35 | Null

36+ | Json Json.Value

35 | Array [Expr]

37 | Array [Expr]

36 | Object [(Name, Expr)]

38 | Object [(Name, Expr)]

37 | Ref Name

39 | Ref Name

@@ -312,6 +314,9 @@ fromExpr indent grouping expression =

312 Null ->

314 Null ->

313 (One, "null")

315 (One, "null")

314

316

317+ Json json ->

318+ ( One, Json.encodeUgly json )

319+

315 Array exprs ->

320 Array exprs ->

316 (,) Many $

321 (,) Many $

317 let

322 let

src/Generate/JavaScript/Expression.hs+39

@@ -3,6 +3,7 @@ module Generate.JavaScript.Expression

3 ( generate

4 , generateCtor

5 , generateFunction

6+ , generateMain

6 , Code

7 , Code

7 , codeToExpr

8 , codeToExpr

8 , codeToStmtList

9 , codeToStmtList

@@ -18,6 +19,9 @@ import qualified Data.Text.Encoding as Text

18import qualified AST.Optimized as Opt

19import qualified AST.Optimized as Opt

19import qualified AST.Module.Name as ModuleName

20import qualified AST.Module.Name as ModuleName

20import qualified Data.Index as Index

21import qualified Data.Index as Index

22+import qualified Elm.Compiler.Type as Type

23+import qualified Elm.Compiler.Type.Extract as Extract

24+import qualified Elm.Interface as I

21import qualified Elm.Name as N

25import qualified Elm.Name as N

22import qualified Elm.Package as Pkg

26import qualified Elm.Package as Pkg

23import qualified Generate.JavaScript.Builder as JS

27import qualified Generate.JavaScript.Builder as JS

@@ -849,3 +853,38 @@ pathToJsExpr mode expr path =

849

853

850 DT.Alias ->

854 DT.Alias ->

851 expr

855 expr

856+

857+

858+

859+-- GENERATE MAIN

860+

861+

862+generateMain :: Mode -> I.Interfaces -> ModuleName.Canonical -> [N.Name] -> Opt.Main -> JS.Expr

863+generateMain mode interfaces home segments main =

864+ case main of

865+ Opt.Static ->

866+ JS.Ref (Name.fromKernel N.browser "staticPage")

867+ # JS.Ref (Name.fromGlobal home "main")

868+ # List.foldl' addDot elm segments

869+

870+ Opt.Dynamic decoder msgType ->

871+ JS.Ref (Name.fromGlobal home "main")

872+ # List.foldl' addDot elm segments

873+ # generateJsExpr mode decoder

874+ # JS.Json (Type.encodeMetadata (Extract.fromMsg interfaces msgType))

875+

876+

877+(#) :: JS.Expr -> JS.Expr -> JS.Expr

878+(#) func arg =

879+ JS.Call func [arg]

880+

881+

882+addDot :: JS.Expr -> N.Name -> JS.Expr

883+addDot root name =

884+ JS.Index root (JS.String (N.toBuilder name))

885+

886+

887+{-# NOINLINE elm #-}

888+elm :: JS.Expr

889+elm =

890+ JS.Ref (Name.fromLocal "Elm")

src/Nitpick/TopLevelTypes.hs+5−2

@@ -16,6 +16,8 @@ import qualified AST.Module.Name as ModuleName

16import qualified AST.Utils.Type as Type

17import qualified Canonicalize.Effects as Effects

18import qualified Elm.Name as N

19+import qualified Optimize.Names as Names

20+import qualified Optimize.Port as Port

19import qualified Reporting.Annotation as A

21import qualified Reporting.Annotation as A

20import qualified Reporting.Error.Main as Error

22import qualified Reporting.Error.Main as Error

21import qualified Reporting.Region as R

23import qualified Reporting.Region as R

@@ -95,14 +97,15 @@ checkMainType region (Can.Forall _ tipe) =

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

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

96 Result.ok Opt.Static

98 Result.ok Opt.Static

98− Can.TType home name [flags, _, _]

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

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

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

100 case Effects.checkPayload flags of

102 case Effects.checkPayload flags of

101 Left (subType, invalidPayload) ->

103 Left (subType, invalidPayload) ->

102 Result.throw (Error.BadFlags region subType invalidPayload)

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

103

105

104 Right () ->

106 Right () ->

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

105− Result.ok (Opt.Dynamic flags)

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

106

109

107 _ ->

110 _ ->

108 Result.throw (Error.BadType region tipe)

111 Result.throw (Error.BadType region tipe)