856ac59 · elk · git.iko.soy

src/AST/Expression/Canonical.hs+38−1

compare with master

unifiedsplit

@@ -1,5 +1,11 @@

1{-# OPTIONS_GHC -Wall #-}

2−module AST.Expression.Canonical where

2+module AST.Expression.Canonical

3+ ( Expr, Expr'

4+ , Def(..)

5+ , Facts(..), dummyFacts

6+ , SortedDefs(..), toSortedDefs

7+ )

8+ where

3

9

4import qualified AST.Expression.General as General

10import qualified AST.Expression.General as General

5import qualified AST.Pattern as Pattern

11import qualified AST.Pattern as Pattern

@@ -33,3 +39,34 @@ dummyFacts :: Facts

33dummyFacts =

39dummyFacts =

34 Facts (error "This should be set by Canonicalize.Sort")

40 Facts (error "This should be set by Canonicalize.Sort")

35

41

42+

43+

44+-- SORTED DEFS

45+

46+

47+data SortedDefs

48+ = NoMain [Def]

49+ | YesMain [Def] Def [Def]

50+

51+

52+toSortedDefs :: Expr -> SortedDefs

53+toSortedDefs (A.A _ expr) =

54+ case expr of

55+ General.Let defs body ->

56+ foldr defCons (toSortedDefs body) defs

57+

58+ _ ->

59+ NoMain []

60+

61+

62+defCons :: Def -> SortedDefs -> SortedDefs

63+defCons def@(Def _ (A.A _ pattern) _ _) sortedDefs =

64+ case (pattern, sortedDefs) of

65+ (Pattern.Var "main", NoMain defs) ->

66+ YesMain [] def defs

67+

68+ (_, NoMain defs) ->

69+ NoMain (def : defs)

70+

71+ (_, YesMain defs main rest) ->

72+ YesMain (def : defs) main rest

src/AST/Expression/General.hs+7

@@ -59,10 +59,17 @@ data Expr' ann def var typ

59 | Sub ModuleName.Canonical

60 | ForeignCmd String typ

61 | ForeignSub String typ

62+ | Program (Main typ) (Expr ann def var typ)

62 | SaveEnv ModuleName.Canonical Effects.Canonical

63 | SaveEnv ModuleName.Canonical Effects.Canonical

63 | GLShader String String Literal.GLShaderTipe

64 | GLShader String String Literal.GLShaderTipe

64

65

66

67+data Main typ

68+ = VDom

69+ | NoFlags

70+ | Flags typ

71+

72+

66

73

67---- UTILITIES ----

74---- UTILITIES ----

68

75

src/AST/Expression/Optimized.hs+2

@@ -5,6 +5,7 @@ module AST.Expression.Optimized

5 , Decider(..), Choice(..)

6 ) where

7

8+import qualified AST.Expression.General as Expr

8import qualified AST.Literal as Literal

9import qualified AST.Literal as Literal

9import qualified AST.Module.Name as ModuleName

10import qualified AST.Module.Name as ModuleName

10import qualified AST.Type as Type

11import qualified AST.Type as Type

@@ -55,6 +56,7 @@ data Expr

55 | Sub ModuleName.Canonical

56 | Sub ModuleName.Canonical

56 | ForeignCmd String Type.Canonical

57 | ForeignCmd String Type.Canonical

57 | ForeignSub String Type.Canonical

58 | ForeignSub String Type.Canonical

59+ | Program (Expr.Main Type.Canonical) Expr

58 | GLShader String String Literal.GLShaderTipe

60 | GLShader String String Literal.GLShaderTipe

59 | Crash ModuleName.Canonical R.Region (Maybe Expr)

61 | Crash ModuleName.Canonical R.Region (Maybe Expr)

60

62

src/Canonicalize.hs+3

@@ -446,6 +446,9 @@ canonicalizeExpr env (A.A region validExpr) =

446 ForeignSub name tipe ->

447 ForeignSub name <$> Canon.tipe env tipe

448

449+ Program _ _ ->

450+ error "DANGER - Program AST nodes should not be in canonicalization."

451+

449 SaveEnv moduleName effects ->

452 SaveEnv moduleName effects ->

450 Result.ok (SaveEnv moduleName effects)

453 Result.ok (SaveEnv moduleName effects)

451

454

src/Canonicalize/Sort.hs+3

@@ -108,6 +108,9 @@ reorder (A.A ann expression) =

108 ForeignSub _ _ ->

109 return expression

110

111+ Program _ _ ->

112+ error "DANGER - Program AST nodes should not be in def sorting."

113+

111 SaveEnv _ _ ->

114 SaveEnv _ _ ->

112 return expression

115 return expression

113

116

src/Compile.hs+15−9

@@ -3,6 +3,7 @@ module Compile (compile) where

3import qualified Data.Map as Map

4

5import qualified AST.Declaration as D

6+import qualified AST.Expression.Canonical as Can

6import qualified AST.Module as Module

7import qualified AST.Module as Module

7import qualified AST.Module.Name as ModuleName

8import qualified AST.Module.Name as ModuleName

8import qualified Canonicalize

9import qualified Canonicalize

@@ -48,22 +49,27 @@ compile packageName canonicalImports interfaces source =

48 TI.infer interfaces canonicalModule

49 TI.infer interfaces canonicalModule

49

50

50 -- One last round of checks

51 -- One last round of checks

52+ canonicalDefs <-

51− Result.format Error.Type $

53+ Result.format Error.Type $

52− Nitpick.topLevelTypes types (Module.validDecls (Module.info validModule))

54+ Nitpick.topLevelTypes types $

55+ Can.toSortedDefs (Module.program (Module.info canonicalModule))

53

56

54 tagDict <-

57 tagDict <-

55 Result.format Error.Pattern $

58 Result.format Error.Pattern $

56 Nitpick.patternMatches interfaces canonicalModule

59 Nitpick.patternMatches interfaces canonicalModule

57

60

58− -- Add the real list of types

59− let canonicalInfo =

60− (Module.info canonicalModule) { Module.types = types }

61−

62 -- Do some basic optimizations

61 -- Do some basic optimizations

63− let optModule =

62+ let optimisedDefs =

64− Optimize.optimize tagDict (canonicalModule { Module.info = canonicalInfo })

63+ Optimize.optimize tagDict (Module.name canonicalModule) canonicalDefs

64+

65+ -- Add the real list of types

66+ let info =

67+ (Module.info canonicalModule)

68+ { Module.types = types

69+ , Module.program = optimisedDefs

70+ }

65

71

66− return optModule

72+ return $ canonicalModule { Module.info = info }

67

73

68

74

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

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

src/Generate/JavaScript/Expression.hs+12

@@ -6,6 +6,7 @@ import qualified Data.List as List

6import qualified Data.Map as Map

7import Language.ECMAScript3.Syntax

8

9+import AST.Expression.General as Expr (Main(..))

9import AST.Expression.Optimized as Opt

10import AST.Expression.Optimized as Opt

10import qualified AST.Literal as L

11import qualified AST.Literal as L

11import qualified AST.Module.Name as ModuleName

12import qualified AST.Module.Name as ModuleName

@@ -214,6 +215,17 @@ generateCode expr =

214 do jsDecoder <- generateJsExpr (Foreign.decode tipe)

215 do jsDecoder <- generateJsExpr (Foreign.decode tipe)

215 jsExpr $ BuiltIn.foreignSub name jsDecoder

216 jsExpr $ BuiltIn.foreignSub name jsDecoder

216

217

218+ Program kind body ->

219+ case kind of

220+ Expr.VDom ->

221+ generateCode (Data "vdom" [body])

222+

223+ Expr.NoFlags ->

224+ generateCode (Data "no-flags" [body])

225+

226+ Expr.Flags tipe ->

227+ generateCode (Data "flags" [Foreign.decode tipe, body])

228+

217 GLShader _uid src _tipe ->

229 GLShader _uid src _tipe ->

218 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

230 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

219

231

src/Nitpick/PatternMatches.hs+3

@@ -193,6 +193,9 @@ checkExpression tagDict (A.A region expression) =

193 E.ForeignSub _ _ ->

194 Result.ok ()

195

196+ E.Program _ _ ->

197+ error "DANGER - Program AST nodes should not be in Nitpick.PatternMatches."

198+

196 E.SaveEnv _ _ ->

199 E.SaveEnv _ _ ->

197 Result.ok ()

200 Result.ok ()

198

201

src/Nitpick/TopLevelTypes.hs+68−31

@@ -1,21 +1,20 @@

1{-# OPTIONS_GHC -Wall #-}

2module Nitpick.TopLevelTypes (topLevelTypes) where

3

4−import Control.Monad (foldM, when)

4+import qualified Data.Foldable as F

5import Data.Map ((!))

6import qualified Data.Map as Map

7−import qualified Data.Maybe as Maybe

8

7

9−import qualified AST.Expression.Valid as Valid

8+import qualified AST.Expression.Canonical as Can

10−import qualified AST.Declaration as Decl

9+import qualified AST.Expression.General as Expr

11import qualified AST.Module.Name as ModuleName

10import qualified AST.Module.Name as ModuleName

12import qualified AST.Pattern as P

11import qualified AST.Pattern as P

13import qualified AST.Type as Type

12import qualified AST.Type as Type

14import qualified AST.Variable as Var

13import qualified AST.Variable as Var

14+import qualified Canonicalize.Effects as Effects

15import qualified Elm.Package as Pkg

16import qualified Reporting.Annotation as A

17import qualified Reporting.Error.Type as Error

18−import qualified Reporting.Region as R

19import qualified Reporting.Result as Result

18import qualified Reporting.Result as Result

20import qualified Reporting.Warning as Warning

19import qualified Reporting.Warning as Warning

21

20

@@ -25,52 +24,85 @@ type Result =

25 Result.Result () Warning.Warning Error.Error

24 Result.Result () Warning.Warning Error.Error

26

25

27

26

27+type TypeDict =

28+ Map.Map String Type.Canonical

29+

30+

31+

28-- CHECK TOP LEVEL TYPES

32-- CHECK TOP LEVEL TYPES

29

33

30

34

31−topLevelTypes :: Map.Map String Type.Canonical -> Decl.Valid -> Result ()

35+topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]

32−topLevelTypes typeEnv (Decl.Decls defs _ _ _) =

36+topLevelTypes typeEnv sortedDefs =

33− do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing defs

37+ let

34− maybe (return ()) (checkMainType typeEnv) maybeMainRegion

38+ check =

39+ checkAnnotation typeEnv

40+ in

41+ case sortedDefs of

42+ Can.NoMain defs ->

43+ pure defs

44+ <* F.traverse_ check defs

35

45

46+ Can.YesMain before main after ->

47+ do check main

48+ <* F.traverse_ check before

49+ <* F.traverse_ check after

36

50

51+ mainDef <- checkMain typeEnv main

52+

53+ return (before ++ mainDef : after)

37

54

38−-- MISSING ANNOTATIONS

39

55

40

56

41−warnMissingAnnotation

57+-- MISSING ANNOTATIONS

42− :: Map.Map String Type.Canonical

58+

43− -> Maybe R.Region

44− -> A.Commented Valid.Def

45− -> Result (Maybe R.Region)

46−warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =

47− case def of

48− Valid.Def (A.A _ (P.Var name)) _ maybeType ->

49− do when (Maybe.isNothing maybeType) $

50− Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name)) ()

51

59

52− return (if name == "main" then Just region else maybeMainRegion)

60+checkAnnotation :: TypeDict -> Can.Def -> Result ()

61+checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =

62+ case (pattern, maybeType) of

63+ (P.Var name, Nothing) ->

64+ let

65+ warning =

66+ Warning.MissingTypeAnnotation name (typeEnv ! name)

67+ in

68+ Result.warn region warning ()

53

69

54 _ ->

70 _ ->

55− return maybeMainRegion

71+ return ()

56

72

57

73

58

74

59-- CHECK MAIN TYPE

75-- CHECK MAIN TYPE

60

76

61

77

62−checkMainType :: Map.Map String Type.Canonical -> R.Region -> Result ()

78+checkMain :: TypeDict -> Can.Def -> Result Can.Def

63−checkMainType typeEnv region =

79+checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

64 let

80 let

65− tipe =

81+ mainType =

66 typeEnv ! "main"

82 typeEnv ! "main"

67− in

68− case Type.deepDealias tipe of

69− Type.App name [_] | name `elem` [program, vdomNode] ->

70− return ()

71

83

84+ makeError tipe maybeMsg =

85+ A.A region (Error.BadFlags tipe maybeMsg)

86+

87+ getMainKind =

88+ case Type.deepDealias mainType of

89+ Type.App name [arg]

90+ | name == vdomNode ->

91+ return Expr.VDom

92+

93+ | name == program && arg == never ->

94+ return Expr.NoFlags

95+

96+ | name == program ->

97+ return (Expr.Flags arg)

98+ <* Effects.checkForeignType makeError arg

99+

72− _ ->

100+ _ ->

73− Result.throw region (Error.BadMain tipe)

101+ Result.throw region (Error.BadMain mainType)

102+ in

103+ do kind <- getMainKind

104+ let newBody = A.A undefined (Expr.Program kind body)

105+ return (Can.Def facts pattern newBody maybeType)

74

106

75

107

76program :: Type.Canonical

108program :: Type.Canonical

@@ -78,6 +110,11 @@ program =

78 Type.Type (Var.inCore ["Platform"] "Program")

110 Type.Type (Var.inCore ["Platform"] "Program")

79

111

80

112

113+never :: Type.Canonical

114+never =

115+ Type.Type (Var.inCore ["Basics"] "Never")

116+

117+

81vdomNode :: Type.Canonical

118vdomNode :: Type.Canonical

82vdomNode =

119vdomNode =

83 let

120 let

src/Optimize.hs+14−30

@@ -7,7 +7,6 @@ import qualified Data.Traversable as T

7import qualified AST.Expression.General as Expr

8import qualified AST.Expression.Canonical as Can

9import qualified AST.Expression.Optimized as Opt

10−import qualified AST.Module as Module

11import qualified AST.Module.Name as ModuleName

10import qualified AST.Module.Name as ModuleName

12import qualified AST.Pattern as P

11import qualified AST.Pattern as P

13import qualified AST.Variable as Var

12import qualified AST.Variable as Var

@@ -23,29 +22,9 @@ import qualified Reporting.Region as R

23-- OPTIMIZE

22-- OPTIMIZE

24

23

25

24

26−optimize :: DT.VariantDict -> Module.Canonical -> Module.Optimized

25+optimize :: DT.VariantDict -> ModuleName.Canonical -> [Can.Def] -> [Opt.Def]

27−optimize variantDict modul@(Module.Module home _ info) =

26+optimize variantDict home defs =

28− let

29− (defs, _) =

30− flattenLets [] (Module.program info)

31−

32− optDefs =

33− Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

27+ Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

34−

35− optInfo =

36− info { Module.program = optDefs }

37− in

38− modul { Module.info = optInfo }

39−

40−

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

42−flattenLets defs annExpr@(A.A _ expr) =

43− case expr of

44− Expr.Let ds body ->

45− flattenLets (defs ++ ds) body

46−

47− _ ->

48− (defs, annExpr)

49

28

50

29

51

30

@@ -57,13 +36,15 @@ optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

57 let

36 let

58 (args, canBody) =

37 (args, canBody) =

59 Expr.collectLambdas expression

38 Expr.collectLambdas expression

60− in

61− do home <-

62− if isRoot then

63− Just <$> Env.getHome

64− else

65− return Nothing

66

39

40+ maybeGetHome =

41+ if isRoot then

42+ Just <$> Env.getHome

43+

44+ else

45+ return Nothing

46+ in

47+ do home <- maybeGetHome

67 optimizeDefHelp home deps pattern args canBody

48 optimizeDefHelp home deps pattern args canBody

68

49

69

50

@@ -313,6 +294,9 @@ optimizeExpr context annExpr@(A.A region expression) =

313 Expr.ForeignSub name tipe ->

294 Expr.ForeignSub name tipe ->

314 pure (Opt.ForeignSub name tipe)

295 pure (Opt.ForeignSub name tipe)

315

296

297+ Expr.Program kind expr ->

298+ Opt.Program kind <$> justConvert expr

299+

316 Expr.SaveEnv _ _ ->

300 Expr.SaveEnv _ _ ->

317 error "save_the_environment should never make it to optimization phase"

301 error "save_the_environment should never make it to optimization phase"

318

302

src/Optimize/Inline.hs+6

@@ -181,6 +181,9 @@ count expression =

181 ForeignSub _ _ ->

182 Map.empty

183

184+ Program _ expr ->

185+ count expr

186+

184 GLShader _ _ _ ->

187 GLShader _ _ _ ->

185 Map.empty

188 Map.empty

186

189

@@ -292,6 +295,9 @@ replace substitutions expression =

292 ForeignSub _ _ ->

295 ForeignSub _ _ ->

293 expression

296 expression

294

297

298+ Program kind expr ->

299+ Program kind (go expr)

300+

295 GLShader _ _ _ ->

301 GLShader _ _ _ ->

296 expression

302 expression

297

303

src/Reporting/Error/Type.hs+21−1

@@ -23,6 +23,7 @@ import qualified Reporting.Report as Report

23data Error

24 = Mismatch Mismatch

25 | BadMain Type.Canonical

26+ | BadFlags Type.Canonical (Maybe String)

26 | InfiniteType String Type.Canonical

27 | InfiniteType String Type.Canonical

27

28

29

@@ -102,7 +103,7 @@ toReport localizer err =

102 Report.report

103 Report.report

103 "BAD MAIN TYPE"

104 "BAD MAIN TYPE"

104 Nothing

105 Nothing

105− "The 'main' value has an unsupported type."

106+ "The `main` value has an unsupported type."

106 ( Help.stack

107 ( Help.stack

107 [ Help.reflowParagraph $

108 [ Help.reflowParagraph $

108 "I need Html, Svg, or a Program so I have something to render on\

109 "I need Html, Svg, or a Program so I have something to render on\

@@ -111,6 +112,25 @@ toReport localizer err =

111 ]

112 ]

112 )

113 )

113

114

115+ BadFlags tipe maybeMessage ->

116+ let

117+ context =

118+ maybe "" (" the following " ++ ) maybeMessage

119+ in

120+ Report.report

121+ "BAD FLAGS"

122+ Nothing

123+ ("Your `main` is demanding an unsupported type as a flag."

124+ )

125+ ( Help.stack

126+ [ text ("The specific unsupported type is" ++ context ++ ":")

127+ , indent 4 (RenderType.toDoc localizer tipe)

128+ , text "The types of values that can flow through in and out of Elm include:"

129+ , indent 4 $ Help.reflowParagraph $

130+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\

131+ \ Tuples, Json.Values, and concrete records."

132+ ]

133+ )

114

134

115

135

116-- TYPE MISMATCHES

136-- TYPE MISMATCHES

src/Type/Constrain/Expression.hs+3

@@ -49,6 +49,9 @@ constrain env annotatedExpr@(A.A region expression) tipe =

49 E.ForeignSub _ _ ->

50 return CTrue

51

52+ E.Program _ _ ->

53+ error "DANGER - Program AST nodes should not be in type inference."

54+

52 E.SaveEnv moduleName effects ->

55 E.SaveEnv moduleName effects ->

53 Effects.constrain env moduleName effects

56 Effects.constrain env moduleName effects

54

57

src/Validate.hs+3

@@ -529,6 +529,9 @@ expression (A.A ann sourceExpression) =

529 ForeignSub name tipe ->

530 return (ForeignSub name tipe)

531

532+ Program _ _ ->

533+ error "DANGER - Program AST nodes should not be in validation phase."

534+

532 SaveEnv moduleName effects ->

535 SaveEnv moduleName effects ->

533 return (SaveEnv moduleName effects)

536 return (SaveEnv moduleName effects)

534

537