8ac06ce · elk · git.iko.soy

src/AST/Expression/General.hs+1−1

@@ -67,7 +67,7 @@ data PortImpl expr tipe

6767 = In String (Type.Port tipe)

6868 | Out String expr (Type.Port tipe)

6969 | Task String expr (Type.Port tipe)

70− deriving (Show)

70+ deriving (Eq, Show)

7171

7272

7373portName :: PortImpl expr tipe -> String

src/AST/Expression/Optimized.hs+6−1

@@ -19,12 +19,14 @@ import qualified Reporting.Region as R

1919data Def

2020 = Def Facts String Expr

2121 | TailDef Facts String [String] Expr

22+ deriving (Eq)

2223

2324

2425data Facts = Facts

2526 { home :: Maybe ModuleName.Canonical

2627 , dependencies :: [Var.TopLevel]

2728 }

29+ deriving (Eq)

2830

2931

3032dummyFacts :: Facts

@@ -54,14 +56,17 @@ data Expr

5456 | Port (General.PortImpl Expr Type.Canonical)

5557 | GLShader String String Literal.GLShaderTipe

5658 | Crash R.Region (Maybe String)

59+ deriving (Eq)

5760

5861

5962data Jump

6063 = Inline Branch

6164 | Jump Int

65+ deriving (Eq)

6266

6367

6468data Branch = Branch

6569 { _substitutions :: [(String, DT.Path)]

6670 , _branch :: Expr

67− }

71+ }

72+ deriving (Eq)

src/AST/Literal.hs+2−2

@@ -39,7 +39,7 @@ data GLTipe

3939 | V4

4040 | M4

4141 | Texture

42− deriving (Show)

42+ deriving (Eq, Show)

4343

4444

4545glTipeName :: GLTipe -> String

@@ -59,4 +59,4 @@ data GLShaderTipe = GLShaderTipe

5959 , uniform :: Map.Map String GLTipe

6060 , varying :: Map.Map String GLTipe

6161 }

62− deriving (Show)

62+ deriving (Eq, Show)

src/AST/Type.hs+1−1

@@ -56,7 +56,7 @@ data Aliased t

5656data Port t

5757 = Normal t

5858 | Signal { root :: t, arg :: t }

59− deriving (Show)

59+ deriving (Eq, Show)

6060

6161

6262getPortType :: Port tipe -> tipe

src/Generate/JavaScript.hs+48−15

@@ -371,28 +371,59 @@ generateDecisionTree root decisionTree =

371371 DT.Match (Opt.Jump target) ->

372372 return [ BreakStmt () (Just (targetLabel root target)) ]

373373

374− DT.Decision testPath edges fallback ->

375− do accessExpr <- generateJsExpr (pathToExpr root testPath)

376−

377− let testExpr =

378− case fst (head edges) of

379− DT.Constructor _ ->

380− DotRef () accessExpr (Id () "ctor")

381−

382− DT.Literal _ ->

383− accessExpr

374+ DT.Decision testPath [(test, subTree)] (Just fallback) ->

375+ let

376+ (tests, deepestSubTree) =

377+ collapseTests [(testPath, test)] fallback subTree

378+

379+ makeTest (path, test) =

380+ do testExpr <- pathToTestableExpr root path test

381+ return (InfixExpr () OpStrictEq testExpr (testToExpr test))

382+ in

383+ do testExprs <- mapM makeTest tests

384+ let cond = List.foldl1' (InfixExpr () OpLAnd) testExprs

385+ thenBranch <- generateDecisionTree root deepestSubTree

386+ elseBranch <- generateDecisionTree root fallback

387+ return [ IfStmt () cond (BlockStmt () thenBranch) (BlockStmt () elseBranch) ]

384388

389+ DT.Decision testPath edges fallback ->

390+ do testExpr <- pathToTestableExpr root testPath (fst (head edges))

385391 caseClauses <- mapM (edgeToCaseClause root) edges

386392 caseDefault <- fallbackToDefault root fallback

387−

388393 return [ SwitchStmt () testExpr (caseClauses ++ caseDefault) ]

389394

390395

396+collapseTests

397+ :: [(DT.Path, DT.Test)]

398+ -> DT.DecisionTree Opt.Jump

399+ -> DT.DecisionTree Opt.Jump

400+ -> ([(DT.Path, DT.Test)], DT.DecisionTree Opt.Jump)

401+collapseTests tests outerFallback decisionTree =

402+ case decisionTree of

403+ DT.Decision testPath [(test, subTree)] (Just fallback)

404+ | fallback == outerFallback ->

405+ collapseTests ((testPath, test) : tests) outerFallback subTree

406+

407+ _ ->

408+ (tests, decisionTree)

409+

410+

391411edgeToCaseClause :: String -> (DT.Test, DT.DecisionTree Opt.Jump) -> State Int (CaseClause ())

392412edgeToCaseClause root (test, subTree) =

393413 CaseClause () (testToExpr test) <$> generateDecisionTree root subTree

394414

395415

416+pathToTestableExpr :: String -> DT.Path -> DT.Test -> State Int (Expression ())

417+pathToTestableExpr root path exampleTest =

418+ do accessExpr <- generateJsExpr (pathToExpr root path)

419+ case exampleTest of

420+ DT.Constructor _ ->

421+ return (DotRef () accessExpr (Id () "ctor"))

422+

423+ DT.Literal _ ->

424+ return accessExpr

425+

426+

396427testToExpr :: DT.Test -> Expression ()

397428testToExpr test =

398429 case test of

@@ -419,15 +450,17 @@ fallbackToDefault root fallback =

419450

420451generateBranch :: String -> Opt.Branch -> State Int [Statement ()]

421452generateBranch root (Opt.Branch substitutions expr) =

422− do subts <- mapM (loadPath root) substitutions

453+ do substs <- mapM (loadPath root) substitutions

454+ let substStmts =

455+ if null substs then [] else [ VarDeclStmt () substs ]

423456 code <- generateCode expr

424− return (subts ++ toStatementList code)

457+ return (substStmts ++ toStatementList code)

425458

426459

427−loadPath :: String -> (String, DT.Path) -> State Int (Statement ())

460+loadPath :: String -> (String, DT.Path) -> State Int (VarDecl ())

428461loadPath root (name, path) =

429462 do jsAccessExpr <- generateJsExpr (pathToExpr root path)

430− return $ VarDeclStmt () [ varDecl name jsAccessExpr ]

463+ return $ varDecl name jsAccessExpr

431464

432465

433466pathToExpr :: String -> DT.Path -> Opt.Expr

src/Optimize/Patterns/DecisionTree.hs+75−31

@@ -12,7 +12,6 @@ as SML/NJ to get nice trees.

1212-}

1313

1414import Control.Arrow (second)

15−import Data.Function (on)

1615import qualified Data.List as List

1716import qualified Data.Map as Map

1817import qualified Data.Set as Set

@@ -74,6 +73,7 @@ data DecisionTree a

7473 , _edges :: [(Test, DecisionTree a)]

7574 , _default :: Maybe (DecisionTree a)

7675 }

76+ deriving (Eq)

7777

7878

7979data Jump = Jump

@@ -144,37 +144,23 @@ toDecisionTree variantDict rawBranches =

144144 Nothing ->

145145 let

146146 path =

147− smallDefaults branches

148−

149− relevantTests =

150− testsAtPath path branches

151−

152− allRawEdges =

153− map (edgesFor path branches) relevantTests

154−

155− (rawEdges, unexplored) =

156− if isComplete variantDict relevantTests then

157− ( init allRawEdges

158− , snd (last allRawEdges)

159− )

147+ pickPath variantDict branches

160148

161− else

162− ( allRawEdges

163− , filter (isIrrelevantTo path) branches

164− )

149+ (edges, fallback) =

150+ gatherEdges variantDict branches path

165151

166− edges =

167− map (second (toDecisionTree variantDict)) rawEdges

152+ decisionEdges =

153+ map (second (toDecisionTree variantDict)) edges

168154 in

169− case (edges, unexplored) of

155+ case (decisionEdges, fallback) of

170156 ([(_tag, decisionTree)], []) ->

171157 decisionTree

172158

173159 (_, []) ->

174− Decision path edges Nothing

160+ Decision path decisionEdges Nothing

175161

176162 (_, _) ->

177− Decision path edges (Just (toDecisionTree variantDict unexplored))

163+ Decision path decisionEdges (Just (toDecisionTree variantDict fallback))

178164

179165

180166isComplete :: VariantDict -> [Test] -> Bool

@@ -283,6 +269,28 @@ getSubstitution (path, A.A _ pattern) =

283269 Nothing

284270

285271

272+-- GATHER OUTGOING EDGES

273+

274+gatherEdges :: VariantDict -> [Branch] -> Path -> ([(Test, [Branch])], [Branch])

275+gatherEdges variantDict branches path =

276+ let

277+ relevantTests =

278+ testsAtPath path branches

279+

280+ allRawEdges =

281+ map (edgesFor path branches) relevantTests

282+ in

283+ if isComplete variantDict relevantTests then

284+ ( init allRawEdges

285+ , snd (last allRawEdges)

286+ )

287+

288+ else

289+ ( allRawEdges

290+ , filter (isIrrelevantTo path) branches

291+ )

292+

293+

286294-- FIND RELEVANT TESTS

287295

288296testsAtPath :: Path -> [Branch] -> [Test]

@@ -420,18 +428,20 @@ needsTests (A.A _ pattern) =

420428 True

421429

422430

423−-- PATH PICKING HEURISTICS

431+-- PICK A PATH

424432

425−smallDefaults :: [Branch] -> Path

426−smallDefaults branches =

433+pickPath :: VariantDict -> [Branch] -> Path

434+pickPath variantDict branches =

427435 let

428436 allPaths =

429437 Maybe.mapMaybe isChoicePath (concatMap _patterns branches)

430−

431− weightedPaths =

432− map (\path -> (path, length (filter (isIrrelevantTo path) branches))) allPaths

433438 in

434− fst (List.minimumBy (compare `on` snd) weightedPaths)

439+ case bests (addWeights (smallDefaults branches) allPaths) of

440+ [path] ->

441+ path

442+

443+ tiedPaths ->

444+ head (bests (addWeights (smallBranchingFactor variantDict branches) tiedPaths))

435445

436446

437447isChoicePath :: (Path, CPattern) -> Maybe Path

@@ -442,4 +452,38 @@ isChoicePath (path, pattern) =

442452 Nothing

443453

444454

445−-- smallBranchingFactor :: [Branch] -> Path

455+addWeights :: (Path -> Int) -> [Path] -> [(Path, Int)]

456+addWeights toWeight paths =

457+ map (\path -> (path, toWeight path)) paths

458+

459+

460+bests :: [(Path, Int)] -> [Path]

461+bests ((path,weight):weightedPaths) =

462+ let

463+ gatherMinimum acc@(minWeight, paths) (path, weight) =

464+ if weight == minWeight then

465+ (minWeight, path : paths)

466+

467+ else if weight < minWeight then

468+ (weight, [path])

469+

470+ else

471+ acc

472+ in

473+ snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)

474+

475+

476+-- PATH PICKING HEURISTICS

477+

478+smallDefaults :: [Branch] -> Path -> Int

479+smallDefaults branches path =

480+ length (filter (isIrrelevantTo path) branches)

481+

482+

483+smallBranchingFactor :: VariantDict -> [Branch] -> Path -> Int

484+smallBranchingFactor variantDict branches path =

485+ let

486+ (edges, fallback) =

487+ gatherEdges variantDict branches path

488+ in

489+ length edges + (if null fallback then 0 else 1)

src/Optimize/Substitute.hsdeleted−103

@@ -1,103 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Optimize.Substitute (subst) where

3−

4−import Control.Arrow (second, (***))

5−

6−import AST.Expression.General (Expr'(..), PortImpl(..))

7−import qualified AST.Expression.Optimized as Optimized

8−import qualified AST.Pattern as Pattern

9−import qualified AST.Variable as V

10−import Elm.Utils ((|>))

11−import qualified Reporting.Annotation as A

12−

13−

14−subst :: String -> Optimized.Expr' -> Optimized.Expr' -> Optimized.Expr'

15−subst old new expression =

16− let f (A.A a e) = A.A a (subst old new e) in

17− case expression of

18− Range lo hi ->

19− Range (f lo) (f hi)

20−

21− ExplicitList exprs ->

22− ExplicitList (map f exprs)

23−

24− Binop op left right ->

25− Binop op (f left) (f right)

26−

27− Lambda pattern body ->

28− if Pattern.member old pattern

29− then expression

30− else Lambda pattern (f body)

31−

32− App func arg ->

33− App (f func) (f arg)

34−

35− If branches finally ->

36− If (map (f *** f) branches) (f finally)

37−

38− Let defs body ->

39− if anyShadow

40− then expression

41− else Let (map substDef defs) (f body)

42− where

43− substDef (Optimized.Definition facts pattern expr) =

44− Optimized.Definition facts pattern (f expr)

45−

46− anyShadow =

47− map (\(Optimized.Definition _ p _) -> p) defs

48− |> any (Pattern.member old)

49−

50− Var (V.Canonical home x) ->

51− case home of

52− V.Module _ ->

53− expression

54−

55− V.BuiltIn ->

56− expression

57−

58− V.Local ->

59− if x == old then new else expression

60−

61− V.TopLevel _ ->

62− if x == old then new else expression

63−

64− Case e cases ->

65− Case (f e) (map substCase cases)

66− where

67− substCase (pattern, expr) =

68− if Pattern.member old pattern

69− then (pattern, expr)

70− else (pattern, f expr)

71−

72− Data tag values ->

73− Data tag (map f values)

74−

75− Access record field ->

76− Access (f record) field

77−

78− Update record fields ->

79− Update (f record) (map (second f) fields)

80−

81− Record fields ->

82− Record (map (second f) fields)

83−

84− Literal _ ->

85− expression

86−

87− GLShader _ _ _ ->

88− expression

89−

90− Port impl ->

91− Port $

92− case impl of

93− In _ _ ->

94− impl

95−

96− Out name expr tipe ->

97− Out name (f expr) tipe

98−

99− Task name expr tipe ->

100− Task name (f expr) tipe

101−

102− Crash _ ->

103− expression

src/Reporting/Region.hs+2−2

@@ -10,14 +10,14 @@ data Region = Region

1010 { start :: Position

1111 , end :: Position

1212 }

13− deriving (Show)

13+ deriving (Eq, Show)

1414

1515

1616data Position = Position

1717 { line :: Int

1818 , column :: Int

1919 }

20− deriving (Show)

20+ deriving (Eq, Show)

2121

2222

2323fromSourcePos :: Parsec.SourcePos -> Position

tests/test-files/good-expected-js/CaseExpression3.elm.js+15−11

@@ -9,15 +9,19 @@ list2) {

99 var _p0 = {ctor: "_Tuple2"

1010 ,_0: list1

1111 ,_1: list2};

12− switch (_p0._0.ctor)

13− {case "Nil": return elm_lang$core$Main$Nil;

14− default: switch (_p0._1.ctor)

15− {case "Nil": return elm_lang$core$Main$Nil;

16− default: var x = _p0._0._0;

17− var xs = _p0._0._1;

18− var y = _p0._1._0;

19− var ys = _p0._1._1;

20− return A2(elm_lang$core$Main$Cons,

21− {ctor: "_Tuple2",_0: x,_1: y},

22− A2(elm_lang$core$Main$zip,xs,ys));}}

12+ if (_p0._0.ctor === "Nil") {

13+ return elm_lang$core$Main$Nil;

14+ } else {

15+ if (_p0._1.ctor === "Nil") {

16+ return elm_lang$core$Main$Nil;

17+ } else {

18+ var x = _p0._0._0,

19+ xs = _p0._0._1,

20+ y = _p0._1._0,

21+ ys = _p0._1._1;

22+ return A2(elm_lang$core$Main$Cons,

23+ {ctor: "_Tuple2",_0: x,_1: y},

24+ A2(elm_lang$core$Main$zip,xs,ys));

25+ }

26+ }

2327});

tests/test-files/good-expected-js/TailRecursive.elm.js+11−10

@@ -2,15 +2,16 @@ var elm_lang$core$Main$_op = {};

22var elm_lang$core$Main$any = F2(function (f,l) {

33 any: while (true) {

44 var _p0 = l;

5− switch (_p0.ctor)

6− {case "::": var x = _p0._0;

7− var xs = _p0._1;

8− if (f(x)) return true; else {

9− var _v0 = f,_v1 = xs;

10− f = _v0;

11− l = _v1;

12− continue any;

13− }

14− default: return false;}

5+ if (_p0.ctor === "::") {

6+ var x = _p0._0,xs = _p0._1;

7+ if (f(x)) return true; else {

8+ var _v0 = f,_v1 = xs;

9+ f = _v0;

10+ l = _v1;

11+ continue any;

12+ }

13+ } else {

14+ return false;

15+ }

1516 }

1617});