a2e92dd · elk · git.iko.soy

git.iko.soy/elk

Generate JS to handle enums and unboxing

commita2e92ddc247b9bbf4bfdded6fbec1fb7076db3a5 authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 12 Jan 2018, 16:23 (9 years ago) parent833ed96

4 files changed+278−95

compare with master

unifiedsplit

src/Data/Index.hs+24−22 src/Generate/JavaScript.hs+49−4 src/Generate/JavaScript/Expression.hs+198−69 src/Generate/JavaScript/Name.hs+7

src/Data/Index.hs+24−22

@@ -1,10 +1,11 @@

11module Data.Index

22 ( ZeroBased

33 , first

4− , unsafe

4+ , second

5+ , third

56 , next

6− , toZeroBased

7− , toOneBased

7+ , toMachine

8+ , toHuman

89 , indexedMap

910 , indexedTraverse

1011 , indexedForA

@@ -32,12 +33,14 @@ first =

3233 ZeroBased 0

3334

3435

35−unsafe :: Int -> ZeroBased

36−unsafe n =

37− if n < 0 then

38− ZeroBased n

39− else

40− error "Compiler error, unacceptable call of Index.unsafe"

36+second :: ZeroBased

37+second =

38+ ZeroBased 1

39+

40+

41+third :: ZeroBased

42+third =

43+ ZeroBased 2

4144

4245

4346{-# INLINE next #-}

@@ -50,13 +53,13 @@ next (ZeroBased i) =

5053-- DESTRUCT

5154

5255

53−toZeroBased :: ZeroBased -> Int

54−toZeroBased (ZeroBased index) =

56+toMachine :: ZeroBased -> Int

57+toMachine (ZeroBased index) =

5558 index

5659

5760

58−toOneBased :: ZeroBased -> Int

59−toOneBased (ZeroBased index) =

61+toHuman :: ZeroBased -> Int

62+toHuman (ZeroBased index) =

6063 index + 1

6164

6265

@@ -66,20 +69,20 @@ toOneBased (ZeroBased index) =

6669

6770{-# INLINE indexedMap #-}

6871indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b]

69−indexedMap func list =

70− zipWith func (map ZeroBased [0 .. length list]) list

72+indexedMap func xs =

73+ zipWith func (map ZeroBased [0 .. length xs]) xs

7174

7275

7376{-# INLINE indexedTraverse #-}

7477indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b]

75−indexedTraverse func list =

76− sequenceA (indexedMap func list)

78+indexedTraverse func xs =

79+ sequenceA (indexedMap func xs)

7780

7881

7982{-# INLINE indexedForA #-}

8083indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b]

81−indexedForA list func =

82− sequenceA (indexedMap func list)

84+indexedForA xs func =

85+ sequenceA (indexedMap func xs)

8386

8487

8588

@@ -113,8 +116,8 @@ indexedZipWithHelp func index listX listY revListZ =

113116indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c)

114117indexedZipWithA func listX listY =

115118 case indexedZipWith func listX listY of

116− LengthMatch list ->

117− LengthMatch <$> sequenceA list

119+ LengthMatch xs ->

120+ LengthMatch <$> sequenceA xs

118121

119122 LengthMismatch x y ->

120123 pure (LengthMismatch x y)

@@ -127,4 +130,3 @@ indexedZipWithA func listX listY =

127130instance Binary ZeroBased where

128131 get = liftM ZeroBased get

129132 put (ZeroBased n) = put n

130−

src/Generate/JavaScript.hs+49−4

@@ -19,6 +19,7 @@ import qualified Data.Text as Text

1919

2020import qualified AST.Optimized as Opt

2121import qualified AST.Module.Name as ModuleName

22+import qualified Data.Index as Index

2223import qualified Elm.Compiler.Type as Type

2324import qualified Elm.Compiler.Type.Extract as Extract

2425import qualified Elm.Interface as I

@@ -153,9 +154,8 @@ addGlobalHelp mode graph global state =

153154 )

154155

155156 Opt.Ctor name index arity ->

156− let (args, ctor) = Expr.generateCtor mode name index arity in

157157 addStmt state (

158− var global (Expr.generateFunction args ctor)

158+ var global (Expr.generateCtor mode name index arity)

159159 )

160160

161161 Opt.Link linkedGlobal ->

@@ -177,6 +177,16 @@ addGlobalHelp mode graph global state =

177177 _ ->

178178 addBuilder (addDeps clientDeps state) (generateKernel mode clientChunks)

179179

180+ Opt.Enum name index ->

181+ addStmt state (

182+ generateEnum mode global name index

183+ )

184+

185+ Opt.Box name ->

186+ addStmt state (

187+ generateBox mode global name

188+ )

189+

180190 Opt.PortIncoming decoder deps ->

181191 addStmt (addDeps deps state) (

182192 generatePort mode global "incomingPort" decoder

@@ -263,7 +273,7 @@ addChunk mode builder chunk =

263273 Opt.JsField int ->

264274 Name.toBuilder (Name.fromInt int) <> builder

265275

266− Opt.Enum int ->

276+ Opt.JsEnum int ->

267277 Name.toBuilder (Name.fromInt int) <> builder

268278

269279 Opt.Debug ->

@@ -284,6 +294,42 @@ addChunk mode builder chunk =

284294

285295

286296

297+-- GENERATE ENUM

298+

299+

300+generateEnum :: Name.Mode -> Opt.Global -> N.Name -> Index.ZeroBased -> JS.Stmt

301+generateEnum mode (Opt.Global home name) ctorName index =

302+ let

303+ definition =

304+ case mode of

305+ Name.Debug _ ->

306+ JS.Object [(Name.dollar, JS.String (N.toBuilder ctorName))]

307+

308+ Name.Prod _ _ ->

309+ JS.Int (Index.toMachine index)

310+ in

311+ JS.Var [ (Name.fromGlobal home name, Just definition) ]

312+

313+

314+

315+-- GENERATE BOX

316+

317+

318+generateBox :: Name.Mode -> Opt.Global -> N.Name -> JS.Stmt

319+generateBox mode (Opt.Global home name) ctorName =

320+ let

321+ definition =

322+ case mode of

323+ Name.Debug _ ->

324+ Expr.codeToExpr $ Expr.generateCtor mode ctorName Index.first 1

325+

326+ Name.Prod _ _ ->

327+ JS.Ref (Name.fromGlobal ModuleName.basics N.identity)

328+ in

329+ JS.Var [ (Name.fromGlobal home name, Just definition) ]

330+

331+

332+

287333-- GENERATE PORTS

288334

289335

@@ -303,7 +349,6 @@ generatePort mode (Opt.Global home name) makePort converter =

303349-- GENERATE MANAGER

304350

305351

306−

307352generateManager :: Name.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State

308353generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state =

309354 let

src/Generate/JavaScript/Expression.hs+198−69

@@ -76,6 +76,20 @@ generate mode expression =

7676 Opt.VarGlobal (Opt.Global home name) ->

7777 JsExpr $ JS.Ref (Name.fromGlobal home name)

7878

79+ Opt.VarEnum (Opt.Global home name) index ->

80+ case mode of

81+ Name.Debug _ ->

82+ JsExpr $ JS.Ref (Name.fromGlobal home name)

83+

84+ Name.Prod _ _ ->

85+ JsExpr $ JS.Int (Index.toMachine index)

86+

87+ Opt.VarBox (Opt.Global home name) ->

88+ JsExpr $ JS.Ref $

89+ case mode of

90+ Name.Debug _ -> Name.fromGlobal home name

91+ Name.Prod _ _ -> Name.fromGlobal ModuleName.basics N.identity

92+

7993 Opt.VarCycle home name ->

8094 JsExpr $ JS.Call (JS.Ref (Name.fromCycle home name)) []

8195

@@ -108,12 +122,16 @@ generate mode expression =

108122 JsBlock $

109123 generateDef mode def : codeToStmtList (generate mode body)

110124

125+ Opt.Destruct (Opt.Destructor name path) body ->

126+ let

127+ pathExpr = generatePath mode path

128+ pathDef = JS.Var [ (Name.fromLocal name, Just pathExpr) ]

129+ in

130+ JsBlock $ pathDef : codeToStmtList (generate mode body)

131+

111132 Opt.Case label root decider jumps ->

112133 JsBlock $ generateCase mode label root decider jumps

113134

114− Opt.Index expr index ->

115− JsExpr $ JS.Access (generateJsExpr mode expr) (Name.fromInt index)

116−

117135 Opt.Accessor field ->

118136 JsExpr $ JS.Function Nothing [Name.dollar]

119137 [ JS.Return $ Just $

@@ -134,7 +152,12 @@ generate mode expression =

134152 JsExpr $ generateRecord mode fields

135153

136154 Opt.Unit ->

137− JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")

155+ case mode of

156+ Name.Debug _ ->

157+ JsExpr $ JS.Ref (Name.fromKernel N.utils "Tuple0")

158+

159+ Name.Prod _ _ ->

160+ JsExpr $ JS.Int 0

138161

139162 Opt.Tuple a b maybeC ->

140163 JsExpr $

@@ -216,21 +239,19 @@ toChar =

216239-- CTOR

217240

218241

219−generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> ([Name.Name], Code)

242+generateCtor :: Mode -> N.Name -> Index.ZeroBased -> Int -> Code

220243generateCtor mode name index arity =

221244 let

222− argNames = map Name.fromInt [1 .. arity]

223− argFields = map (\n -> (n, JS.Ref n)) argNames

245+ argNames =

246+ Index.indexedMap (\i _ -> Name.fromIndex i) [1 .. arity]

224247

225− tag =

248+ ctorTag =

226249 case mode of

227− Name.Debug _ ->

228− ( Name.dollar, JS.String (N.toBuilder name) )

229−

230− Name.Prod _ _ ->

231− ( Name.dollar, JS.Int (Index.toZeroBased index) )

250+ Name.Debug _ -> JS.String (N.toBuilder name)

251+ Name.Prod _ _ -> JS.Int (Index.toMachine index)

232252 in

233− ( argNames, JsExpr (JS.Object (tag:argFields)) )

253+ generateFunction argNames $ JsExpr $ JS.Object $

254+ (Name.dollar, ctorTag) : map (\n -> (n, JS.Ref n)) argNames

234255

235256

236257

@@ -334,14 +355,32 @@ generateCall mode func args =

334355 Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core ->

335356 generateCoreCall mode global args

336357

358+ Opt.VarBox _ ->

359+ case mode of

360+ Name.Debug _ ->

361+ generateCallHelp mode func args

362+

363+ Name.Prod _ _ ->

364+ case args of

365+ [arg] ->

366+ generateJsExpr mode arg

367+

368+ _ ->

369+ generateCallHelp mode func args

370+

337371 _ ->

338− generateNormalCall

339− (generateJsExpr mode func)

340− (map (generateJsExpr mode) args)

372+ generateCallHelp mode func args

341373

342374

343−generateNormalCall' :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

344−generateNormalCall' home name args =

375+generateCallHelp :: Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr

376+generateCallHelp mode func args =

377+ generateNormalCall

378+ (generateJsExpr mode func)

379+ (map (generateJsExpr mode) args)

380+

381+

382+generateGlobalCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

383+generateGlobalCall home name args =

345384 generateNormalCall (JS.Ref (Name.fromGlobal home name)) args

346385

347386

@@ -385,8 +424,11 @@ generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name)

385424 else if moduleName == N.tuple then

386425 generateTupleCall home name (map (generateJsExpr mode) args)

387426

427+ else if moduleName == N.jsArray then

428+ generateJsArrayCall home name (map (generateJsExpr mode) args)

429+

388430 else

389− generateNormalCall' home name (map (generateJsExpr mode) args)

431+ generateGlobalCall home name (map (generateJsExpr mode) args)

390432

391433

392434generateTupleCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

@@ -396,10 +438,18 @@ generateTupleCall home name args =

396438 case name of

397439 "first" -> JS.Access value (Name.fromLocal "a")

398440 "second" -> JS.Access value (Name.fromLocal "b")

399− _ -> generateNormalCall' home name args

441+ _ -> generateGlobalCall home name args

400442

401443 _ ->

402− generateNormalCall' home name args

444+ generateGlobalCall home name args

445+

446+

447+generateJsArrayCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

448+generateJsArrayCall home name args =

449+ case args of

450+ [entry] | name == "singleton" -> JS.Array [entry]

451+ [index, array] | name == "unsafeGet" -> JS.Index array index

452+ _ -> generateGlobalCall home name args

403453

404454

405455generateBitwiseCall :: ModuleName.Canonical -> N.Name -> [JS.Expr] -> JS.Expr

@@ -408,7 +458,7 @@ generateBitwiseCall home name args =

408458 [arg] ->

409459 case name of

410460 "complement" -> JS.Prefix JS.PrefixBNot arg

411− _ -> generateNormalCall' home name args

461+ _ -> generateGlobalCall home name args

412462

413463 [left,right] ->

414464 case name of

@@ -418,10 +468,10 @@ generateBitwiseCall home name args =

418468 "shiftLeftBy" -> JS.Infix JS.OpLShift right left

419469 "shiftRightBy" -> JS.Infix JS.OpSpRShift right left

420470 "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left

421− _ -> generateNormalCall' home name args

471+ _ -> generateGlobalCall home name args

422472

423473 _ ->

424− generateNormalCall' home name args

474+ generateGlobalCall home name args

425475

426476

427477generateBasicsCall :: Mode -> ModuleName.Canonical -> N.Name -> [Opt.Expr] -> JS.Expr

@@ -433,7 +483,7 @@ generateBasicsCall mode home name args =

433483 "not" -> JS.Prefix JS.PrefixLNot arg

434484 "toFloat" -> arg

435485 "truncate" -> JS.Infix JS.OpBOr arg (JS.Int 0)

436− _ -> generateNormalCall' home name [arg]

486+ _ -> generateGlobalCall home name [arg]

437487

438488 [elmLeft, elmRight] ->

439489 case name of

@@ -462,10 +512,10 @@ generateBasicsCall mode home name args =

462512 "or" -> JS.Infix JS.OpLOr left right

463513 "and" -> JS.Infix JS.OpLAnd left right

464514 "xor" -> JS.Infix JS.OpStrictNEq left right

465− _ -> generateNormalCall' home name [left, right]

515+ _ -> generateGlobalCall home name [left, right]

466516

467517 _ ->

468− generateNormalCall' home name (map (generateJsExpr mode) args)

518+ generateGlobalCall home name (map (generateJsExpr mode) args)

469519

470520

471521equal :: JS.Expr -> JS.Expr -> JS.Expr

@@ -676,6 +726,31 @@ generateDef mode def =

676726

677727

678728

729+-- PATHS

730+

731+

732+generatePath :: Mode -> Opt.Path -> JS.Expr

733+generatePath mode path =

734+ case path of

735+ Opt.Index index subPath ->

736+ JS.Access (generatePath mode subPath) (Name.fromIndex index)

737+

738+ Opt.Root name ->

739+ JS.Ref (Name.fromLocal name)

740+

741+ Opt.Field field subPath ->

742+ JS.Access (generatePath mode subPath) (Name.fromField mode field)

743+

744+ Opt.Unbox subPath ->

745+ case mode of

746+ Name.Debug _ ->

747+ JS.Access (generatePath mode subPath) (Name.fromIndex Index.first)

748+

749+ Name.Prod _ _ ->

750+ generatePath mode subPath

751+

752+

753+

679754-- GENERATE IFS

680755

681756

@@ -770,45 +845,69 @@ generateDecider mode label root decisionTree =

770845 [ JS.Break (Just (Name.makeLabel label index)) ]

771846

772847 Opt.Chain testChain success failure ->

773− let

774− makeTest (path, test) =

775− strictEq

776− (pathToTestableExpr mode root path test)

777− (testToExpr mode test)

778− in

779848 [ JS.IfStmt

780− (List.foldl1' (JS.Infix JS.OpLAnd) (map makeTest testChain))

849+ (List.foldl1' (JS.Infix JS.OpLAnd) (map (generateIfTest mode root) testChain))

781850 (JS.Block $ generateDecider mode label root success)

782851 (JS.Block $ generateDecider mode label root failure)

783852 ]

784853

785854 Opt.FanOut path edges fallback ->

786855 [ JS.Switch

787− (pathToTestableExpr mode root path (fst (head edges)))

856+ (generateCaseTest mode root path (fst (head edges)))

788857 ( foldr

789− (addCase mode label root)

858+ (\edge cases -> generateCaseBranch mode label root edge : cases)

790859 [ JS.Default (generateDecider mode label root fallback) ]

791860 edges

792861 )

793862 ]

794863

795864

796−addCase :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> [JS.Case] -> [JS.Case]

797−addCase mode label root (test, subTree) cases =

798− let stmts = generateDecider mode label root subTree in

799− JS.Case (testToExpr mode test) stmts : cases

865+generateIfTest :: Mode -> N.Name -> (DT.Path, DT.Test) -> JS.Expr

866+generateIfTest mode root (path, test) =

867+ let

868+ value = pathToJsExpr mode root path

869+ in

870+ case test of

871+ DT.IsCtor name index _ _ ->

872+ strictEq (JS.Access value Name.dollar) $

873+ case mode of

874+ Name.Debug _ -> JS.String (N.toBuilder name)

875+ Name.Prod _ _ -> JS.Int (Index.toMachine index)

876+

877+ DT.IsInt int ->

878+ strictEq value (JS.Int int)

800879

880+ DT.IsChr char ->

881+ strictEq (JS.String (Text.encodeUtf8Builder char)) $

882+ case mode of

883+ Name.Debug _ -> JS.Call (JS.Access value (Name.fromLocal "valueOf")) []

884+ Name.Prod _ _ -> value

801885

802−testToExpr :: Mode -> DT.Test -> JS.Expr

803−testToExpr mode test =

886+ DT.IsStr string ->

887+ strictEq value (JS.String (Text.encodeUtf8Builder string))

888+

889+ DT.IsCons ->

890+ JS.Access value (Name.fromLocal "b")

891+

892+ DT.IsNil ->

893+ JS.Prefix JS.PrefixLNot $

894+ JS.Access value (Name.fromLocal "b")

895+

896+

897+generateCaseBranch :: Mode -> N.Name -> N.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case

898+generateCaseBranch mode label root (test, subTree) =

899+ JS.Case

900+ (generateCaseValue mode test)

901+ (generateDecider mode label root subTree)

902+

903+

904+generateCaseValue :: Mode -> DT.Test -> JS.Expr

905+generateCaseValue mode test =

804906 case test of

805− DT.IsCtor _ tag index ->

907+ DT.IsCtor name index _ _ ->

806908 case mode of

807− Name.Debug _ ->

808− JS.String (N.toBuilder tag)

809−

810− Name.Prod _ _ ->

811− JS.Int (Index.toZeroBased index)

909+ Name.Debug _ -> JS.String (N.toBuilder name)

910+ Name.Prod _ _ -> JS.Int (Index.toMachine index)

812911

813912 DT.IsInt int ->

814913 JS.Int int

@@ -819,46 +918,76 @@ testToExpr mode test =

819918 DT.IsStr string ->

820919 JS.String (Text.encodeUtf8Builder string)

821920

921+ DT.IsCons ->

922+ error "COMPILER BUG - there should never be three tests on a list"

822923

823−pathToTestableExpr :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr

824−pathToTestableExpr mode root path exampleTest =

924+ DT.IsNil ->

925+ error "COMPILER BUG - there should never be three tests on a list"

926+

927+

928+generateCaseTest :: Mode -> N.Name -> DT.Path -> DT.Test -> JS.Expr

929+generateCaseTest mode root path exampleTest =

825930 let

826− expr =

827− pathToJsExpr mode (JS.Ref (Name.fromLocal root)) path

931+ value = pathToJsExpr mode root path

828932 in

829933 case exampleTest of

830− DT.IsCtor _ _ _ ->

831− JS.Access expr Name.dollar

934+ DT.IsCtor _ _ _ opts ->

935+ case mode of

936+ Name.Debug _ ->

937+ JS.Access value Name.dollar

938+

939+ Name.Prod _ _ ->

940+ case opts of

941+ Can.Normal ->

942+ JS.Access value Name.dollar

943+

944+ Can.Enum ->

945+ value

946+

947+ Can.Unbox ->

948+ value

832949

833950 DT.IsInt _ ->

834− expr

951+ value

835952

836953 DT.IsStr _ ->

837− expr

954+ value

838955

839956 DT.IsChr _ ->

840957 case mode of

841958 Name.Debug _ ->

842− JS.Call (JS.Access expr (Name.fromLocal "valueOf")) []

959+ JS.Call (JS.Access value (Name.fromLocal "valueOf")) []

843960

844961 Name.Prod _ _ ->

845− expr

962+ value

846963

964+ DT.IsCons ->

965+ error "COMPILER BUG - there should never be three tests on a list"

847966

848−pathToJsExpr :: Mode -> JS.Expr -> DT.Path -> JS.Expr

849−pathToJsExpr mode expr path =

967+ DT.IsNil ->

968+ error "COMPILER BUG - there should never be three tests on a list"

969+

970+

971+

972+-- PATTERN PATHS

973+

974+

975+pathToJsExpr :: Mode -> N.Name -> DT.Path -> JS.Expr

976+pathToJsExpr mode root path =

850977 case path of

851− DT.Index index subpath ->

852− pathToJsExpr mode (JS.Access expr (Name.fromInt index)) subpath

978+ DT.Index index subPath ->

979+ JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex index)

853980

854− DT.Field field subpath ->

855− pathToJsExpr mode (JS.Access expr (Name.fromField mode field)) subpath

981+ DT.Unbox subPath ->

982+ case mode of

983+ Name.Debug _ ->

984+ JS.Access (pathToJsExpr mode root subPath) (Name.fromIndex Index.first)

856985

857− DT.Empty ->

858− expr

986+ Name.Prod _ _ ->

987+ pathToJsExpr mode root subPath

859988

860− DT.Alias ->

861− expr

989+ DT.Empty ->

990+ JS.Ref (Name.fromLocal root)

862991

863992

864993

src/Generate/JavaScript/Name.hs+7

@@ -6,6 +6,7 @@ module Generate.JavaScript.Name

66 , Target(..)

77 , isServer

88 , toBuilder

9+ , fromIndex

910 , fromInt

1011 , fromLocal

1112 , fromGlobal

@@ -32,6 +33,7 @@ import qualified Data.Text.Encoding as Text

3233import Data.Word (Word8)

3334

3435import qualified AST.Module.Name as ModuleName

36+import qualified Data.Index as Index

3537import qualified Elm.Name as N

3638import qualified Elm.Package as Pkg

3739

@@ -76,6 +78,11 @@ isServerHelp target =

7678-- CONSTRUCTORS

7779

7880

81+fromIndex :: Index.ZeroBased -> Name

82+fromIndex index =

83+ fromInt (Index.toMachine index)

84+

85+

7986fromInt :: Int -> Name

8087fromInt n =

8188 Name (B.shortByteString (intToAscii n))