856ac59 · elk · git.iko.soy

git.iko.soy/elk

Check programs that take flags, generate relevant decoder

When you have a `Program flags` we need to check that `flags` is a value that can be passed in from JS. If so, we generate a JSON decoder to bring it in safely or throw an error.

commit856ac59c1a32d64754c08f00936f895c2a79b870 authorEvan Czaplicki <info@elm-lang.org> dateTue 29 Mar 2016, 19:41 (11 years ago) parent1b28a32

14 files changed+198−72

compare with master

unifiedsplit

src/AST/Expression/Canonical.hs+38−1 src/AST/Expression/General.hs+7 src/AST/Expression/Optimized.hs+2 src/Canonicalize.hs+3 src/Canonicalize/Sort.hs+3 src/Compile.hs+15−9 src/Generate/JavaScript/Expression.hs+12 src/Nitpick/PatternMatches.hs+3 src/Nitpick/TopLevelTypes.hs+68−31 src/Optimize.hs+14−30 src/Optimize/Inline.hs+6 src/Reporting/Error/Type.hs+21−1 src/Type/Constrain/Expression.hs+3 src/Validate.hs+3

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

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

11{-# 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

410import qualified AST.Expression.General as General

511import qualified AST.Pattern as Pattern

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

3339dummyFacts =

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

3541

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

5959 | Sub ModuleName.Canonical

6060 | ForeignCmd String typ

6161 | ForeignSub String typ

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

6263 | SaveEnv ModuleName.Canonical Effects.Canonical

6364 | GLShader String String Literal.GLShaderTipe

6465

6566

67+data Main typ

68+ = VDom

69+ | NoFlags

70+ | Flags typ

71+

72+

6673

6774---- UTILITIES ----

6875

src/AST/Expression/Optimized.hs+2

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

55 , Decider(..), Choice(..)

66 ) where

8+import qualified AST.Expression.General as Expr

89import qualified AST.Literal as Literal

910import qualified AST.Module.Name as ModuleName

1011import qualified AST.Type as Type

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

5556 | Sub ModuleName.Canonical

5657 | ForeignCmd String Type.Canonical

5758 | ForeignSub String Type.Canonical

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

5860 | GLShader String String Literal.GLShaderTipe

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

6062

src/Canonicalize.hs+3

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

446446 ForeignSub name tipe ->

447447 ForeignSub name <$> Canon.tipe env tipe

448448

449+ Program _ _ ->

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

451+

449452 SaveEnv moduleName effects ->

450453 Result.ok (SaveEnv moduleName effects)

451454

src/Canonicalize/Sort.hs+3

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

108108 ForeignSub _ _ ->

109109 return expression

110110

111+ Program _ _ ->

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

113+

111114 SaveEnv _ _ ->

112115 return expression

113116

src/Compile.hs+15−9

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

33import qualified Data.Map as Map

55import qualified AST.Declaration as D

6+import qualified AST.Expression.Canonical as Can

67import qualified AST.Module as Module

78import qualified AST.Module.Name as ModuleName

89import qualified Canonicalize

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

4849 TI.infer interfaces canonicalModule

4950

5051 -- One last round of checks

51− Result.format Error.Type $

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

52+ canonicalDefs <-

53+ Result.format Error.Type $

54+ Nitpick.topLevelTypes types $

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

5356

5457 tagDict <-

5558 Result.format Error.Pattern $

5659 Nitpick.patternMatches interfaces canonicalModule

5760

58− -- Add the real list of types

59− let canonicalInfo =

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

61−

6261 -- Do some basic optimizations

63− let optModule =

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

62+ let optimisedDefs =

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+ }

6571

66− return optModule

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

6773

6874

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

src/Generate/JavaScript/Expression.hs+12

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

66import qualified Data.Map as Map

77import Language.ECMAScript3.Syntax

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

910import AST.Expression.Optimized as Opt

1011import qualified AST.Literal as L

1112import qualified AST.Module.Name as ModuleName

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

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

215216 jsExpr $ BuiltIn.foreignSub name jsDecoder

216217

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+

217229 GLShader _uid src _tipe ->

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

219231

src/Nitpick/PatternMatches.hs+3

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

193193 E.ForeignSub _ _ ->

194194 Result.ok ()

195195

196+ E.Program _ _ ->

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

198+

196199 E.SaveEnv _ _ ->

197200 Result.ok ()

198201

src/Nitpick/TopLevelTypes.hs+68−31

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

11{-# OPTIONS_GHC -Wall #-}

22module Nitpick.TopLevelTypes (topLevelTypes) where

4−import Control.Monad (foldM, when)

4+import qualified Data.Foldable as F

55import Data.Map ((!))

66import qualified Data.Map as Map

7−import qualified Data.Maybe as Maybe

9−import qualified AST.Expression.Valid as Valid

10−import qualified AST.Declaration as Decl

8+import qualified AST.Expression.Canonical as Can

9+import qualified AST.Expression.General as Expr

1110import qualified AST.Module.Name as ModuleName

1211import qualified AST.Pattern as P

1312import qualified AST.Type as Type

1413import qualified AST.Variable as Var

14+import qualified Canonicalize.Effects as Effects

1515import qualified Elm.Package as Pkg

1616import qualified Reporting.Annotation as A

1717import qualified Reporting.Error.Type as Error

18−import qualified Reporting.Region as R

1918import qualified Reporting.Result as Result

2019import qualified Reporting.Warning as Warning

2120

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

2524 Result.Result () Warning.Warning Error.Error

2625

2726

27+type TypeDict =

28+ Map.Map String Type.Canonical

29+

30+

31+

2832-- CHECK TOP LEVEL TYPES

2933

3034

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

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

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

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

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

36+topLevelTypes typeEnv sortedDefs =

37+ let

38+ check =

39+ checkAnnotation typeEnv

40+ in

41+ case sortedDefs of

42+ Can.NoMain defs ->

43+ pure defs

44+ <* F.traverse_ check defs

3545

46+ Can.YesMain before main after ->

47+ do check main

48+ <* F.traverse_ check before

49+ <* F.traverse_ check after

3650

51+ mainDef <- checkMain typeEnv main

52+

53+ return (before ++ mainDef : after)

3754

38−-- MISSING ANNOTATIONS

3955

4056

41−warnMissingAnnotation

42− :: Map.Map String Type.Canonical

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)) ()

57+-- MISSING ANNOTATIONS

58+

5159

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 ()

5369

5470 _ ->

55− return maybeMainRegion

71+ return ()

5672

5773

5874

5975-- CHECK MAIN TYPE

6076

6177

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

63−checkMainType typeEnv region =

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

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

6480 let

65− tipe =

81+ mainType =

6682 typeEnv ! "main"

67− in

68− case Type.deepDealias tipe of

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

70− return ()

7183

72− _ ->

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

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+

100+ _ ->

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)

74106

75107

76108program :: Type.Canonical

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

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

79111

80112

113+never :: Type.Canonical

114+never =

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

116+

117+

81118vdomNode :: Type.Canonical

82119vdomNode =

83120 let

src/Optimize.hs+14−30

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

77import qualified AST.Expression.General as Expr

88import qualified AST.Expression.Canonical as Can

99import qualified AST.Expression.Optimized as Opt

10−import qualified AST.Module as Module

1110import qualified AST.Module.Name as ModuleName

1211import qualified AST.Pattern as P

1312import qualified AST.Variable as Var

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

2322-- OPTIMIZE

2423

2524

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

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

28− let

29− (defs, _) =

30− flattenLets [] (Module.program info)

31−

32− optDefs =

33− 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)

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

26+optimize variantDict home defs =

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

4928

5029

5130

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

5736 let

5837 (args, canBody) =

5938 Expr.collectLambdas expression

60− in

61− do home <-

62− if isRoot then

63− Just <$> Env.getHome

64− else

65− return Nothing

6639

40+ maybeGetHome =

41+ if isRoot then

42+ Just <$> Env.getHome

43+

44+ else

45+ return Nothing

46+ in

47+ do home <- maybeGetHome

6748 optimizeDefHelp home deps pattern args canBody

6849

6950

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

313294 Expr.ForeignSub name tipe ->

314295 pure (Opt.ForeignSub name tipe)

315296

297+ Expr.Program kind expr ->

298+ Opt.Program kind <$> justConvert expr

299+

316300 Expr.SaveEnv _ _ ->

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

318302

src/Optimize/Inline.hs+6

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

181181 ForeignSub _ _ ->

182182 Map.empty

183183

184+ Program _ expr ->

185+ count expr

186+

184187 GLShader _ _ _ ->

185188 Map.empty

186189

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

292295 ForeignSub _ _ ->

293296 expression

294297

298+ Program kind expr ->

299+ Program kind (go expr)

300+

295301 GLShader _ _ _ ->

296302 expression

297303

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

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

2323data Error

2424 = Mismatch Mismatch

2525 | BadMain Type.Canonical

26+ | BadFlags Type.Canonical (Maybe String)

2627 | InfiniteType String Type.Canonical

2728

2829

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

102103 Report.report

103104 "BAD MAIN TYPE"

104105 Nothing

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

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

106107 ( Help.stack

107108 [ Help.reflowParagraph $

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

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

111112 ]

112113 )

113114

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+ )

114134

115135

116136-- TYPE MISMATCHES

src/Type/Constrain/Expression.hs+3

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

4949 E.ForeignSub _ _ ->

5050 return CTrue

5151

52+ E.Program _ _ ->

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

54+

5255 E.SaveEnv moduleName effects ->

5356 Effects.constrain env moduleName effects

5457

src/Validate.hs+3

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

529529 ForeignSub name tipe ->

530530 return (ForeignSub name tipe)

531531

532+ Program _ _ ->

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

534+

532535 SaveEnv moduleName effects ->

533536 return (SaveEnv moduleName effects)

534537