97572f9 · elk · git.iko.soy

src/AST/Module.hs+2−2

compare with master

unifiedsplit

@@ -60,7 +60,7 @@ type CanonicalModule =

60

61

62type Optimized =

63− [Optimized.Def]

63+ Module Docs.Centralized [Name.Raw] [Var.Value] (Body [Optimized.Def])

64

65

66data Module docs imports exports body = Module

@@ -124,7 +124,7 @@ data Interface = Interface

124 }

125

126

127−toInterface :: Package.Name -> CanonicalModule -> Interface

127+toInterface :: Package.Name -> Optimized -> Interface

128toInterface pkgName modul =

129 let body' = body modul in

130 Interface

src/Compile.hs+12−5

@@ -9,6 +9,7 @@ import Elm.Utils ((|>))

9import qualified Elm.Package as Package

10import qualified Nitpick.PatternMatches as Nitpick

11import qualified Nitpick.TopLevelTypes as Nitpick

12+import qualified Optimize

12import qualified Parse.Helpers as Parse

13import qualified Parse.Helpers as Parse

13import qualified Parse.Parse as Parse

14import qualified Parse.Parse as Parse

14import qualified Reporting.Error as Error

15import qualified Reporting.Error as Error

@@ -23,7 +24,7 @@ compile

23 -> [ModuleName.Canonical]

24 -> [ModuleName.Canonical]

24 -> Module.Interfaces

25 -> Module.Interfaces

25 -> String

26 -> String

26− -> Result.Result Warning.Warning Error.Error Module.CanonicalModule

27+ -> Result.Result Warning.Warning Error.Error Module.Optimized

27

28

28compile packageName isRoot canonicalImports interfaces source =

29compile packageName isRoot canonicalImports interfaces source =

29 do

30 do

@@ -45,13 +46,19 @@ compile packageName isRoot canonicalImports interfaces source =

45 Result.mapError Error.Type $

46 Result.mapError Error.Type $

46 Nitpick.topLevelTypes types (Module.body validModule)

47 Nitpick.topLevelTypes types (Module.body validModule)

47

48

49+ tagDict <-

48− Result.mapError Error.Pattern $

50+ Result.mapError Error.Pattern $

49− Nitpick.patternMatches interfaces canonicalModule

51+ Nitpick.patternMatches interfaces canonicalModule

50

52

51 -- Add the real list of types

53 -- Add the real list of types

54+ let body =

52− let body = (Module.body canonicalModule) { Module.types = types }

55+ (Module.body canonicalModule) { Module.types = types }

53

56

57+ -- Do some basic optimizations

58+ let optModule =

54− return $ canonicalModule { Module.body = body }

59+ Optimize.optimize tagDict (canonicalModule { Module.body = body })

60+

61+ return optModule

55

62

56

63

57getOpTable :: Module.Interfaces -> Parse.OpTable

64getOpTable :: Module.Interfaces -> Parse.OpTable

src/Elm/Compiler.hs+2−4

@@ -20,7 +20,6 @@ import qualified Elm.Compiler.Module as PublicModule

20import qualified Elm.Docs as Docs

21import qualified Elm.Package as Package

22import qualified Generate.JavaScript as JS

23−import qualified Optimize

24import qualified Parse.Module as Parse

23import qualified Parse.Module as Parse

25import qualified Parse.Parse as Parse

24import qualified Parse.Parse as Parse

26import qualified Reporting.Annotation as A

25import qualified Reporting.Annotation as A

@@ -77,8 +76,7 @@ compile context source interfaces =

77 docs <- docsGen isExposed modul

76 docs <- docsGen isExposed modul

78

77

79 let interface = Module.toInterface packageName modul

78 let interface = Module.toInterface packageName modul

80− let optModule = Optimize.optimize modul

81− let javascript = JS.generate optModule

79+ let javascript = JS.generate modul

82

80

83 return (Result docs interface javascript)

81 return (Result docs interface javascript)

84 in

82 in

@@ -105,7 +103,7 @@ data Result = Result

105

103

106docsGen

104docsGen

107 :: Bool

105 :: Bool

108− -> Module.CanonicalModule

106+ -> Module.Optimized

109 -> Result.Result w Error.Error (Maybe Docs.Documentation)

107 -> Result.Result w Error.Error (Maybe Docs.Documentation)

110docsGen isExposed modul =

108docsGen isExposed modul =

111 if not isExposed then

109 if not isExposed then

src/Generate/JavaScript.hs+4−1

@@ -24,8 +24,11 @@ import qualified Optimize.Patterns.DecisionTree as DT

24

25

26generate :: Module.Optimized -> String

27−generate definitions =

27+generate module_ =

28 let

29+ definitions =

30+ Module.program (Module.body module_)

31+

29 stmts =

32 stmts =

30 State.evalState (mapM generateDef definitions) 0

33 State.evalState (mapM generateDef definitions) 0

31 in

34 in

src/Nitpick/PatternMatches.hs+22−12

@@ -16,6 +16,7 @@ import qualified AST.Pattern as Pattern

16import qualified AST.Variable as Var

17import Elm.Utils ((|>))

18import Nitpick.Pattern (Pattern(..), fromCanonicalPattern)

19+import qualified Optimize.Patterns.DecisionTree as Opt

19import qualified Reporting.Annotation as A

20import qualified Reporting.Annotation as A

20import qualified Reporting.Error.Pattern as Error

21import qualified Reporting.Error.Pattern as Error

21import qualified Reporting.Region as Region

22import qualified Reporting.Region as Region

@@ -25,31 +26,40 @@ import qualified Reporting.Result as Result

25patternMatches

26patternMatches

26 :: Module.Interfaces

27 :: Module.Interfaces

27 -> Module.CanonicalModule

28 -> Module.CanonicalModule

28− -> Result.Result w Error.Error ()

29+ -> Result.Result w Error.Error Opt.VariantDict

29patternMatches interfaces modul =

30patternMatches interfaces modul =

30 let

31 let

31 name = Module.name modul

32 name = Module.name modul

32 body = Module.body modul

33 body = Module.body modul

34+ tagDict =

35+ toTagDict interfaces name (Module.datatypes body)

33 in

36 in

34− checkExpression

37+ const (Map.map (Map.map length) tagDict)

35− (toTagDict interfaces name (Module.datatypes body))

36− (Module.program body)

38+ <$> checkExpression tagDict (Module.program body)

37

39

38

40

39-- TAG DICT

41-- TAG DICT

40

42

41type TagDict =

43type TagDict =

42− Map.Map Var.Home (Map.Map Tag [(Tag, Int)])

44+ Map.Map Var.Home (Map.Map Tag [TagInfo])

43

45

44

46

45type Tag = String

47type Tag = String

46

48

47

49

50+data TagInfo = TagInfo

51+ { _tag :: Tag

52+ , _arity :: Int

53+ }

54+

55+

48toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict

56toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict

49toTagDict interfaces localName localAdts =

57toTagDict interfaces localName localAdts =

50 let

58 let

51 listTags =

59 listTags =

52− [ ("::", 2), ("[]", 0) ]

60+ [ TagInfo "::" 2

61+ , TagInfo "[]" 0

62+ ]

53

63

54 builtinDict =

64 builtinDict =

55 Map.singleton Var.BuiltIn $

65 Map.singleton Var.BuiltIn $

@@ -67,12 +77,12 @@ toTagDict interfaces localName localAdts =

67 Map.union builtinDict interfaceDict

77 Map.union builtinDict interfaceDict

68

78

69

79

70−toTagMapping :: Module.ADTs -> Map.Map Tag ([(Tag,Int)])

80+toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]

71toTagMapping adts =

81toTagMapping adts =

72 let

82 let

73 toTagAndArity (_tvars, tagInfoList) =

83 toTagAndArity (_tvars, tagInfoList) =

74 let

84 let

75− info = map (\(tag, args) -> (tag, length args)) tagInfoList

85+ info = map (\(tag, args) -> TagInfo tag (length args)) tagInfoList

76 in

86 in

77 map (second (const info)) tagInfoList

87 map (second (const info)) tagInfoList

78 in

88 in

@@ -81,7 +91,7 @@ toTagMapping adts =

81 |> Map.fromList

91 |> Map.fromList

82

92

83

93

84−lookupOtherTags :: Var.Canonical -> TagDict -> [(Tag, Int)]

94+lookupOtherTags :: Var.Canonical -> TagDict -> [TagInfo]

85lookupOtherTags (Var.Canonical home name) tagDict =

95lookupOtherTags (Var.Canonical home name) tagDict =

86 case Map.lookup name =<< Map.lookup home tagDict of

96 case Map.lookup name =<< Map.lookup home tagDict of

87 Just otherTags ->

97 Just otherTags ->

@@ -89,7 +99,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =

89

99

90 Nothing ->

100 Nothing ->

91 if Help.isTuple name then

101 if Help.isTuple name then

92− [(name, read (drop 6 name))]

102+ [ TagInfo name (read (drop 6 name)) ]

93 else

103 else

94 error

104 error

95 "Since the Nitpick phase happens after canonicalization and type \

105 "Since the Nitpick phase happens after canonicalization and type \

@@ -339,8 +349,8 @@ complementData tagDict tag patterns =

339 tagComplements ++ argComplements

349 tagComplements ++ argComplements

340

350

341

351

342−tagToPattern :: Var.Canonical -> (Tag, Int) -> Maybe Pattern

352+tagToPattern :: Var.Canonical -> TagInfo -> Maybe Pattern

343−tagToPattern (Var.Canonical home rootTag) (tag, arity) =

353+tagToPattern (Var.Canonical home rootTag) (TagInfo tag arity) =

344 if rootTag == tag then

354 if rootTag == tag then

345 Nothing

355 Nothing

346 else

356 else

src/Optimize.hs+7−18

@@ -2,7 +2,6 @@ module Optimize (optimize) where

2

3import Control.Applicative

4import qualified Control.Monad as M

5−import qualified Data.Map as Map

6import qualified Data.Traversable as T

5import qualified Data.Traversable as T

7

6

8import qualified AST.Expression.General as Expr

7import qualified AST.Expression.General as Expr

@@ -12,35 +11,25 @@ import qualified AST.Module as Module

12import qualified AST.Module.Name as ModuleName

11import qualified AST.Module.Name as ModuleName

13import qualified AST.Pattern as P

12import qualified AST.Pattern as P

14import qualified AST.Variable as Var

13import qualified AST.Variable as Var

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

16import qualified Optimize.Environment as Env

14import qualified Optimize.Environment as Env

17import qualified Optimize.Patterns as Patterns

15import qualified Optimize.Patterns as Patterns

16+import qualified Optimize.Patterns.DecisionTree as DT

18import qualified Reporting.Annotation as A

17import qualified Reporting.Annotation as A

19import qualified Reporting.Region as R

18import qualified Reporting.Region as R

20

19

21

20

22−-- OPTIMIZE - turn a canonical module into a list of optimized defs

21+-- OPTIMIZE

23

22

24−optimize :: Module.CanonicalModule -> Module.Optimized

23+optimize :: DT.VariantDict -> Module.CanonicalModule -> Module.Optimized

25−optimize (Module.Module home _ _ _ _ body) =

24+optimize variantDict module_@(Module.Module home _ _ _ _ body) =

26 let

25 let

27 (defs, _) =

26 (defs, _) =

28 flattenLets [] (Module.program body)

27 flattenLets [] (Module.program body)

29

28

30− variantInfo (_, tags) =

29+ optDefs =

31− let

30+ Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

32− variants = length tags

33− in

34− map (\(tag, _) -> (Var.fromModule home tag, variants)) tags

35−

36− variantDict =

37− Module.datatypes body

38− |> Map.elems

39− |> concatMap variantInfo

40− |> Map.fromList

41− |> Map.insert (Var.builtin "_Tuple2") 1

42 in

31 in

43− Env.run variantDict (concat <$> mapM (optimizeDef (Just home)) defs)

32+ module_ { Module.body = body { Module.program = optDefs } }

44

33

45

34

46flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

35flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

src/Optimize/Patterns/DecisionTree.hs+20−5

@@ -16,9 +16,9 @@ import Data.Function (on)

16import qualified Data.List as List

17import qualified Data.Map as Map

18import qualified Data.Set as Set

19−import Data.Map ((!))

20import qualified Data.Maybe as Maybe

19import qualified Data.Maybe as Maybe

21

20

21+import qualified AST.Helpers as Help

22import qualified AST.Literal as L

23import qualified AST.Pattern as P

24import qualified AST.Variable as Var

@@ -62,7 +62,7 @@ contain things like [ ("Just", 2), ("Nothing", 2), ("_Tuple2", 1), ... ] which

62we can use for these optimizations.

63-}

64type VariantDict =

65− Map.Map Var.Canonical Int

65+ Map.Map Var.Home (Map.Map String Int)

66

67

68-- DECISION TREES

@@ -180,8 +180,8 @@ toDecisionTree variantDict rawBranches =

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

181isComplete variantDict tests =

182 case head tests of

183− Constructor name ->

183+ Constructor var ->

184− (variantDict ! name) == length tests

184+ getArity variantDict var == length tests

185

186 Literal (L.Boolean _) ->

187 length tests == 2

@@ -190,6 +190,21 @@ isComplete variantDict tests =

190 False

191

192

193+getArity :: VariantDict -> Var.Canonical -> Int

194+getArity variantDict (Var.Canonical home name) =

195+ case Map.lookup name =<< Map.lookup home variantDict of

196+ Just arity ->

197+ arity

198+

199+ Nothing ->

200+ if Help.isTuple name then

201+ read (drop 6 name)

202+

203+ else

204+ error

205+ "Since the Optimize phase happens after canonicalization and type \

206+ \inference, it is impossible that a pattern cannot be found."

207+

193

208

194-- FLATTEN PATTERNS

209-- FLATTEN PATTERNS

195

210

@@ -219,7 +234,7 @@ flatten variantDict pathPattern@(path, A.A ann pattern) =

219 [pathPattern]

234 [pathPattern]

220

235

221 P.Data tag patterns ->

236 P.Data tag patterns ->

222− if variantDict ! tag == 1 then

237+ if getArity variantDict tag == 1 then

223 concatMap (flatten variantDict) (subPositions path patterns)

238 concatMap (flatten variantDict) (subPositions path patterns)

224

239

225 else

240 else