967c895 · elk · git.iko.soy

.travis.yml−1

@@ -22,5 +22,4 @@ install:

2222

2323script:

2424 - cabal configure --enable-tests

25− - cabal build

2625 - cabal test

elm-compiler.cabal+25−13

@@ -1,6 +1,6 @@

11

22Name: elm-compiler

3−Version: 0.16

3+Version: 0.17

44

55Synopsis:

66 Values to help with elm-package, elm-make, and elm-lang.org.

@@ -18,7 +18,7 @@ License-file: LICENSE

1818

1919Author: Evan Czaplicki

2020Maintainer: info@elm-lang.org

2222

2323Category: Compiler, Language

2424

@@ -31,9 +31,18 @@ source-repository head

3131 type: git

3232 location: git://github.com/elm-lang/elm-compiler.git

3333

34+

35+Flag dev {

36+ Description: Turn off optimization and make warnings errors

37+ Default: False

38+}

39+

40+

3441Library

35− ghc-options:

36− -O2 -W

42+ if flag(dev)

43+ ghc-options: -O0 -W -Werror

44+ else

45+ ghc-options: -O2

3746

3847 Hs-Source-Dirs:

3948 src

@@ -48,6 +57,7 @@ Library

4857

4958 other-modules:

5059 AST.Declaration,

60+ AST.Effects,

5161 AST.Expression.Canonical,

5262 AST.Expression.General,

5363 AST.Expression.Optimized,

@@ -61,10 +71,9 @@ Library

6171 AST.Type,

6272 AST.Variable,

6373 Canonicalize,

64− Canonicalize.Declaration,

74+ Canonicalize.Body,

75+ Canonicalize.Effects,

6576 Canonicalize.Environment,

66− Canonicalize.Port,

67− Canonicalize.Result,

6877 Canonicalize.Setup,

6978 Canonicalize.Sort,

7079 Canonicalize.Type,

@@ -77,11 +86,12 @@ Library

7786 Elm.Compiler.Type.Extract,

7887 Elm.Compiler.Version,

7988 Generate.JavaScript,

89+ Generate.JavaScript.Builder,

8090 Generate.JavaScript.BuiltIn,

8191 Generate.JavaScript.Expression,

92+ Generate.JavaScript.Foreign,

8293 Generate.JavaScript.Helpers,

8394 Generate.JavaScript.Literal,

84− Generate.JavaScript.Port,

8595 Generate.JavaScript.Variable,

8696 Nitpick.Pattern,

8797 Nitpick.PatternMatches,

@@ -101,6 +111,7 @@ Library

101111 Parse.Pattern,

102112 Parse.Type,

103113 Reporting.Annotation,

114+ Reporting.Bag,

104115 Reporting.Error,

105116 Reporting.Error.Canonicalize,

106117 Reporting.Error.Docs,

@@ -114,6 +125,7 @@ Library

114125 Reporting.Report,

115126 Reporting.Result,

116127 Reporting.Warning,

128+ Type.Constrain.Effects,

117129 Type.Constrain.Expression,

118130 Type.Constrain.Literal,

119131 Type.Constrain.Pattern,

@@ -147,8 +159,7 @@ Library

147159 pretty >= 1.0 && < 2.0,

148160 process,

149161 text >= 1 && < 2,

150− union-find >= 0.2 && < 0.3,

151− wl-pprint

162+ union-find >= 0.2 && < 0.3

152163

153164

154165Executable elm

@@ -176,6 +187,9 @@ Executable elm

176187

177188

178189Test-Suite compiler-tests

190+ ghc-options:

191+ -O0

192+

179193 Type:

180194 exitcode-stdio-1.0

181195

@@ -208,7 +222,6 @@ Test-Suite compiler-tests

208222 containers >= 0.3 && < 0.6,

209223 directory >= 1.0 && < 2.0,

210224 edit-distance >= 0.2 && < 0.3,

211− elm-compiler,

212225 filemanip >= 0.3.5 && < 0.4,

213226 filepath >= 1 && < 2.0,

214227 indents >= 0.3 && < 0.4,

@@ -219,5 +232,4 @@ Test-Suite compiler-tests

219232 pretty >= 1.0 && < 2.0,

220233 process,

221234 text >= 1 && < 2,

222− union-find >= 0.2 && < 0.3,

223− wl-pprint

235+ union-find >= 0.2 && < 0.3

src/AST/Declaration.hs+111−55

@@ -3,7 +3,6 @@ module AST.Declaration where

33

44import Data.Binary

55

6−import qualified AST.Expression.General as General

76import qualified AST.Expression.Source as Source

87import qualified AST.Expression.Valid as Valid

98import qualified AST.Expression.Canonical as Canonical

@@ -11,86 +10,143 @@ import qualified AST.Type as Type

1110import qualified Reporting.Annotation as A

1211

1312

14−-- DECLARATIONS

1513

16−data Declaration' port def tipe expr

17− = Definition def

18− | Datatype String [String] [(String, [tipe])]

19− | TypeAlias String [String] tipe

20− | Port port

21− | Fixity Assoc Int String

14+-- SOURCE DECLARATIONS

2215

2316

24−-- INFIX STUFF

17+type Source =

18+ CommentOr (A.Located Raw)

2519

26−data Assoc = L | N | R

27− deriving (Eq)

2820

21+data CommentOr a

22+ = Comment (A.Located String)

23+ | Whatever a

2924

30−assocToString :: Assoc -> String

31−assocToString assoc =

32− case assoc of

33− L -> "left"

34− N -> "non"

35− R -> "right"

25+

26+data Raw

27+ = Def Source.Def

28+ | Union (Union Type.Raw)

29+ | Alias (Alias Type.Raw)

30+ | Fixity Infix

31+ | Port String Type.Raw

32+

33+

34+

35+-- STRUCTURED DECLARATIONS

3636

3737

38−-- DECLARATION PHASES

38+data Decls def tipe =

39+ Decls

40+ { _defs :: [A.Commented def]

41+ , _unions :: [A.Commented (Union tipe)]

42+ , _aliases :: [A.Commented (Alias tipe)]

43+ , _infixes :: [Infix]

44+ }

3945

40−type SourceDecl' =

41− Declaration' SourcePort Source.Def Type.Raw Source.Expr

4246

47+type Valid =

48+ Decls Valid.Def Type.Raw

4349

44−data SourceDecl

45− = Comment String

46− | Decl (A.Located SourceDecl')

4750

51+type Canonical =

52+ Decls Canonical.Def Type.Canonical

4853

49−type ValidDecl =

50− A.Commented (Declaration' ValidPort Valid.Def Type.Raw Valid.Expr)

5154

55+addDef :: A.Commented d -> Decls d t -> Decls d t

56+addDef def decls =

57+ decls { _defs = def : _defs decls }

5258

53−type CanonicalDecl =

54− A.Commented (Declaration' CanonicalPort Canonical.Def Type.Canonical Canonical.Expr)

5559

60+addUnion :: A.Commented (Union t) -> Decls d t -> Decls d t

61+addUnion union decls =

62+ decls { _unions = union : _unions decls }

5663

57−-- PORTS

5864

59−data SourcePort

60− = PortAnnotation String Type.Raw

61− | PortDefinition String Source.Expr

65+addAlias :: A.Commented (Alias t) -> Decls d t -> Decls d t

66+addAlias alias decls =

67+ decls { _aliases = alias : _aliases decls }

6268

6369

64−data ValidPort

65− = In String Type.Raw

66− | Out String Valid.Expr Type.Raw

70+addInfix :: Infix -> Decls d t -> Decls d t

71+addInfix fixity decls =

72+ decls { _infixes = fixity : _infixes decls }

6773

6874

69−newtype CanonicalPort

70− = CanonicalPort (General.PortImpl Canonical.Expr Type.Canonical)

7175

76+-- TYPE DECLARATIONS

77+

78+

79+data Type body =

80+ Type

81+ { _name :: String

82+ , _args :: [String]

83+ , _body :: body

84+ }

85+

86+

87+type Union tipe =

88+ Type [(String, [tipe])]

89+

90+

91+type Alias tipe =

92+ Type tipe

93+

94+

95+

96+-- INFIX STUFF

97+

98+

99+data Infix =

100+ Infix

101+ { _op :: String

102+ , _associativity :: Assoc

103+ , _precedence :: Int

104+ }

105+

106+

107+data Assoc = L | N | R

108+ deriving (Eq)

109+

110+

111+assocToString :: Assoc -> String

112+assocToString assoc =

113+ case assoc of

114+ L ->

115+ "left"

116+

117+ N ->

118+ "non"

119+

120+ R ->

121+ "right"

72122

73−validPortName :: ValidPort -> String

74−validPortName port =

75− case port of

76− In name _ -> name

77− Out name _ _ -> name

78123

79124

80125-- BINARY CONVERSION

81126

127+

128+instance Binary Infix where

129+ get =

130+ Infix <$> get <*> get <*> get

131+

132+ put (Infix op assoc prec) =

133+ do put op

134+ put assoc

135+ put prec

136+

137+

82138instance Binary Assoc where

83− get =

84− do n <- getWord8

85− return $ case n of

86− 0 -> L

87− 1 -> N

88− 2 -> R

89− _ -> error "Error reading valid associativity from serialized string"

90−

91− put assoc =

92− putWord8 $

93− case assoc of

94− L -> 0

95− N -> 1

96− R -> 2

139+ get =

140+ do n <- getWord8

141+ return $ case n of

142+ 0 -> L

143+ 1 -> N

144+ 2 -> R

145+ _ -> error "Error reading valid associativity from serialized string"

146+

147+ put assoc =

148+ putWord8 $

149+ case assoc of

150+ L -> 0

151+ N -> 1

152+ R -> 2

src/AST/Effects.hsnew file+68

@@ -0,0 +1,68 @@

1+module AST.Effects where

2+

3+import qualified AST.Type as Type

4+import qualified Elm.Package as Pkg

5+import qualified Reporting.Annotation as A

6+import qualified Reporting.Region as R

7+

8+

9+

10+-- EFFECTS

11+

12+

13+data Effects pkg ports

14+ = None

15+ | Manager pkg Info

16+ | Port ports

17+

18+

19+type Raw =

20+ Effects () [A.Commented PortRaw]

21+

22+

23+type Canonical =

24+ Effects Pkg.Name [A.Commented PortCanonical]

25+

26+

27+

28+-- EFFECT MANAGERS

29+

30+

31+data Info =

32+ Info

33+ { _tag :: R.Region

34+ , _init :: R.Region

35+ , _onEffects :: R.Region

36+ , _onSelfMsg :: R.Region

37+ , _managerType :: ManagerType

38+ }

39+

40+

41+data ManagerType

42+ = CmdManager (A.Located String)

43+ | SubManager (A.Located String)

44+ | FxManager (A.Located String) (A.Located String)

45+

46+

47+

48+-- FOREIGN EFFECTS

49+

50+

51+data PortRaw =

52+ PortRaw

53+ { _rawName :: String

54+ , _rawType :: Type.Raw

55+ }

56+

57+

58+data PortCanonical =

59+ PortCanonical

60+ { _name :: String

61+ , _kind :: Kind

62+ , _type :: Type.Canonical

63+ }

64+

65+

66+data Kind

67+ = Outgoing Type.Canonical

68+ | Incoming Type.Canonical

src/AST/Expression/Canonical.hs+39−2

@@ -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

39

410import qualified AST.Expression.General as General

511import qualified AST.Pattern as Pattern

@@ -21,7 +27,7 @@ type Expr' =

2127

2228

2329data Def

24− = Definition Facts Pattern.CanonicalPattern Expr (Maybe (A.Located Type.Canonical))

30+ = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

2531

2632

2733data Facts = Facts

@@ -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+27−39

@@ -8,15 +8,18 @@ enrich the AST with more information.

88-}

99module AST.Expression.General where

1010

11+import qualified AST.Effects as Effects

1112import qualified AST.Literal as Literal

13+import qualified AST.Module.Name as ModuleName

1214import qualified AST.Pattern as Pattern

13−import qualified AST.Type as Type

1415import qualified AST.Variable as Var

1516import qualified Reporting.Annotation as A

1617

1718

19+

1820---- GENERAL AST ----

1921

22+

2023{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

2124"type holes" that allow us to enrich the AST with additional information as we

2225move through the compilation process. The type holes are used to represent:

@@ -52,29 +55,25 @@ data Expr' ann def var typ

5255 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

5356 | Record [(String, Expr ann def var typ)]

5457 -- for type checking and code gen only

55− | Port (PortImpl (Expr ann def var typ) typ)

58+ | Cmd ModuleName.Canonical

59+ | Sub ModuleName.Canonical

60+ | OutgoingPort String typ

61+ | IncomingPort String typ

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

63+ | SaveEnv ModuleName.Canonical Effects.Canonical

5664 | GLShader String String Literal.GLShaderTipe

5765

5866

59−-- PORTS

60−

61−data PortImpl expr tipe

62− = In String (Type.Port tipe)

63− | Out String expr (Type.Port tipe)

64− | Task String expr (Type.Port tipe)

65− deriving (Eq)

67+data Main typ

68+ = VDom

69+ | NoFlags

70+ | Flags typ

6671

6772

68−portName :: PortImpl expr tipe -> String

69−portName impl =

70− case impl of

71− In name _ -> name

72− Out name _ _ -> name

73− Task name _ _ -> name

74−

7573

7674---- UTILITIES ----

7775

76+

7877rawVar :: String -> Expr' ann def Var.Raw typ

7978rawVar x =

8079 Var (Var.Raw x)

@@ -90,35 +89,24 @@ tuple expressions =

9089 Data ("_Tuple" ++ show (length expressions)) expressions

9190

9291

93−saveEnvName :: String

94−saveEnvName =

95− "_save_the_environment!!!"

96−

97−

98−dummyLet :: [def] -> Expr ann def Var.Canonical typ

99−dummyLet defs =

100− let body =

101− A.A undefined (Var (Var.builtin saveEnvName))

102− in

103− A.A undefined (Let defs body)

104−

105−

10692collectApps :: Expr ann def var typ -> [Expr ann def var typ]

10793collectApps annExpr@(A.A _ expr) =

10894 case expr of

109− App a b -> collectApps a ++ [b]

110− _ -> [annExpr]

95+ App a b ->

96+ collectApps a ++ [b]

97+

98+ _ ->

99+ [annExpr]

111100

112101

113−collectLambdas

114− :: Expr ann def var typ

115− -> ([Pattern.Pattern ann var], Expr ann def var typ)

102+collectLambdas :: Expr ann def var typ -> ([Pattern.Pattern ann var], Expr ann def var typ)

116103collectLambdas lexpr@(A.A _ expr) =

117104 case expr of

118105 Lambda pattern body ->

119− let

120− (ps, body') = collectLambdas body

121− in

122− (pattern : ps, body')

106+ let

107+ (ps, body') = collectLambdas body

108+ in

109+ (pattern : ps, body')

123110

124− _ -> ([], lexpr)

111+ _ ->

112+ ([], lexpr)

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

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

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

66 ) where

77

8−import qualified AST.Expression.General as General

8+import qualified AST.Expression.General as Expr

99import qualified AST.Literal as Literal

1010import qualified AST.Module.Name as ModuleName

1111import qualified AST.Type as Type

@@ -52,7 +52,11 @@ data Expr

5252 | Access Expr String

5353 | Update Expr [(String, Expr)]

5454 | Record [(String, Expr)]

55− | Port (General.PortImpl Expr Type.Canonical)

55+ | Cmd ModuleName.Canonical

56+ | Sub ModuleName.Canonical

57+ | OutgoingPort String Type.Canonical

58+ | IncomingPort String Type.Canonical

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

5660 | GLShader String String Literal.GLShaderTipe

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

5862

src/AST/Expression/Source.hs+2−2

@@ -26,6 +26,6 @@ type Def =

2626

2727

2828data Def'

29− = Definition Pattern.RawPattern Expr

30− | TypeAnnotation String Type.Raw

29+ = Definition Pattern.Raw Expr

30+ | Annotation String Type.Raw

3131

src/AST/Expression/Valid.hs+7−2

@@ -20,6 +20,11 @@ type Expr' =

2020 General.Expr' R.Region Def Var.Raw Type.Raw

2121

2222

23−data Def

24− = Definition Pattern.RawPattern Expr (Maybe Type.Raw)

23+data Def =

24+ Def Pattern.Raw Expr (Maybe Type.Raw)

25+

26+

27+getPattern :: Def -> Pattern.Raw

28+getPattern (Def pattern _ _) =

29+ pattern

2530

src/AST/Module.hs+152−83

@@ -1,18 +1,25 @@

11module AST.Module

2− ( Interfaces

3− , Types, Aliases, ADTs

4− , AdtInfo, CanonicalAdt

5− , SourceModule, ValidModule, CanonicalModule, Optimized

6− , Module(..), Body(..)

7− , Header(..)

8− , Interface(..), toInterface

2+ ( Header(..), Module(..)

3+

4+ , Source, SourceInfo(..), SourceTag(..), SourceSettings, emptySettings

5+ , Valid, ValidInfo(..)

6+ , Canonical, Optimized, Info(..)

7+

98 , UserImport, DefaultImport, ImportMethod(..)

10− ) where

9+

10+ , Types

11+ , Aliases

12+ , Unions, UnionInfo, CanonicalUnion

13+

14+ , Interfaces, Interface(..), toInterface

15+ )

16+ where

1117

1218import Data.Binary

1319import qualified Data.Map as Map

1420

1521import qualified AST.Declaration as Decl

22+import qualified AST.Effects as Effects

1623import qualified AST.Expression.Canonical as Canonical

1724import qualified AST.Expression.Optimized as Optimized

1825import qualified AST.Module.Name as Name

@@ -22,78 +29,92 @@ import qualified Docs.AST as Docs

2229import qualified Elm.Package as Package

2330import qualified Elm.Compiler.Version as Compiler

2431import qualified Reporting.Annotation as A

32+import qualified Reporting.Region as R

2533

2634

27−-- HELPFUL TYPE ALIASES

2835

29−type Interfaces = Map.Map Name.Canonical Interface

36+-- HEADERS FOR PARSING

3037

31−type Types = Map.Map String Type.Canonical

32−type Aliases = Map.Map String ([String], Type.Canonical)

33−type ADTs = Map.Map String (AdtInfo String)

3438

35−type AdtInfo v = ( [String], [(v, [Type.Canonical])] )

36−type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

39+{-| Basic info needed to identify modules and determine dependencies. -}

40+data Header imports =

41+ Header

42+ { _tag :: SourceTag

43+ , _name :: Name.Raw

44+ , _exports :: Var.Listing (A.Located Var.Value)

45+ , _settings :: SourceSettings

46+ , _docs :: A.Located (Maybe String)

47+ , _imports :: imports

48+ }

49+

3750

3851

3952-- MODULES

4053

41−type SourceModule =

42− Module

43− String

44− [UserImport]

45− (Var.Listing (A.Located Var.Value))

46− [Decl.SourceDecl]

4754

55+data Module phase =

56+ Module

57+ { name :: Name.Canonical

58+ , path :: FilePath

59+ , info :: phase

60+ }

4861

49−type ValidModule =

50− Module

51− String

52− ([DefaultImport], [UserImport])

53− (Var.Listing (A.Located Var.Value))

54− [Decl.ValidDecl]

5562

63+type Source =

64+ Module SourceInfo

5665

57−type CanonicalModule =

58− Module Docs.Centralized [Name.Raw] [Var.Value] (Body Canonical.Expr)

5966

67+data SourceInfo =

68+ Source

69+ { srcTag :: SourceTag

70+ , srcSettings :: SourceSettings

71+ , srcDocs :: A.Located (Maybe String)

72+ , srcExports :: Var.Listing (A.Located Var.Value)

73+ , srcImports :: [UserImport]

74+ , srcDecls :: [Decl.Source]

75+ }

6076

61−type Optimized =

62− Module Docs.Centralized [Name.Raw] [Var.Value] (Body [Optimized.Def])

6377

78+data SourceTag

79+ = Normal

80+ | Effect R.Region

81+ | Port R.Region

6482

65−data Module docs imports exports body = Module

66− { name :: Name.Canonical

67− , path :: FilePath

68− , docs :: A.Located (Maybe docs)

69− , exports :: exports

70− , imports :: imports

71− , body :: body

72− }

7383

84+type SourceSettings =

85+ A.Located [(A.Located String, A.Located String)]

7486

75−data Body expr = Body

76− { program :: expr

77− , types :: Types

78− , fixities :: [(Decl.Assoc, Int, String)]

79− , aliases :: Aliases

80− , datatypes :: ADTs

81− , ports :: [String]

82− }

8387

88+emptySettings :: SourceSettings

89+emptySettings =

90+ A.A (error "region of empty settings should not be needed") []

8491

85−-- HEADERS

8692

87−{-| Basic info needed to identify modules and determine dependencies. -}

88−data Header imports = Header

89− { _name :: Name.Raw

90− , _docs :: A.Located (Maybe String)

91− , _exports :: Var.Listing (A.Located Var.Value)

92− , _imports :: imports

93+type Valid =

94+ Module ValidInfo

95+

96+

97+data ValidInfo =

98+ Valid

99+ { validDocs :: A.Located (Maybe String)

100+ , validExports :: Var.Listing (A.Located Var.Value)

101+ , validImports :: ([DefaultImport], [UserImport])

102+ , validDecls :: Decl.Valid

103+ , validEffects :: Effects.Raw

93104 }

94105

95106

96−-- IMPORTs

107+type Canonical =

108+ Module (Info Canonical.Expr)

109+

110+

111+type Optimized =

112+ Module (Info [Optimized.Def])

113+

114+

115+

116+-- IMPORTS

117+

97118

98119type UserImport = A.Located (Name.Raw, ImportMethod)

99120

@@ -101,53 +122,101 @@ type UserImport = A.Located (Name.Raw, ImportMethod)

101122type DefaultImport = (Name.Raw, ImportMethod)

102123

103124

104−data ImportMethod = ImportMethod

125+data ImportMethod =

126+ ImportMethod

105127 { alias :: Maybe String

106128 , exposedVars :: !(Var.Listing Var.Value)

107129 }

108130

109131

132+

133+-- LATE PHASE MODULE INFORMATION

134+

135+

136+data Info program =

137+ Info

138+ { docs :: A.Located (Maybe Docs.Centralized)

139+ , exports :: [Var.Value]

140+ , imports :: [Name.Raw]

141+ , program :: program

142+ , types :: Types

143+ , fixities :: [Decl.Infix]

144+ , aliases :: Aliases

145+ , unions :: Unions

146+ , effects :: Effects.Canonical

147+ }

148+

149+

150+type Types =

151+ Map.Map String Type.Canonical

152+

153+

154+type Aliases =

155+ Map.Map String ([String], Type.Canonical)

156+

157+

158+type Unions =

159+ Map.Map String (UnionInfo String)

160+

161+

162+type UnionInfo v =

163+ ( [String], [(v, [Type.Canonical])] )

164+

165+

166+type CanonicalUnion =

167+ ( Var.Canonical, UnionInfo Var.Canonical )

168+

169+

170+

110171-- INTERFACES

111172

173+

174+type Interfaces =

175+ Map.Map Name.Canonical Interface

176+

177+

112178{-| Key facts about a module, used when reading info from .elmi files. -}

113−data Interface = Interface

179+data Interface =

180+ Interface

114181 { iVersion :: Package.Version

115182 , iPackage :: Package.Name

116183 , iExports :: [Var.Value]

117− , iTypes :: Types

118184 , iImports :: [Name.Raw]

119− , iAdts :: ADTs

185+ , iTypes :: Types

186+ , iUnions :: Unions

120187 , iAliases :: Aliases

121− , iFixities :: [(Decl.Assoc, Int, String)]

122− , iPorts :: [String]

188+ , iFixities :: [Decl.Infix]

123189 }

124190

125191

126192toInterface :: Package.Name -> Optimized -> Interface

127193toInterface pkgName modul =

128− let body' = body modul in

194+ let

195+ myInfo =

196+ info modul

197+ in

129198 Interface

130− { iVersion = Compiler.version

131− , iPackage = pkgName

132− , iExports = exports modul

133− , iTypes = types body'

134− , iImports = imports modul

135− , iAdts = datatypes body'

136− , iAliases = aliases body'

137− , iFixities = fixities body'

138− , iPorts = ports body'

139− }

199+ { iVersion = Compiler.version

200+ , iPackage = pkgName

201+ , iExports = exports myInfo

202+ , iImports = imports myInfo

203+ , iTypes = types myInfo

204+ , iUnions = unions myInfo

205+ , iAliases = aliases myInfo

206+ , iFixities = fixities myInfo

207+ }

140208

141209

142210instance Binary Interface where

143− get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

144− put modul = do

145− put (iVersion modul)

146− put (iPackage modul)

147− put (iExports modul)

148− put (iTypes modul)

149− put (iImports modul)

150− put (iAdts modul)

151− put (iAliases modul)

152− put (iFixities modul)

153− put (iPorts modul)

211+ get =

212+ Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

213+

214+ put modul =

215+ do put (iVersion modul)

216+ put (iPackage modul)

217+ put (iExports modul)

218+ put (iImports modul)

219+ put (iTypes modul)

220+ put (iUnions modul)

221+ put (iAliases modul)

222+ put (iFixities modul)

src/AST/Module/Name.hs+6−1

@@ -18,7 +18,12 @@ data Canonical = Canonical

1818

1919inCore :: Raw -> Canonical

2020inCore raw =

21− Canonical Package.coreName raw

21+ Canonical Package.core raw

22+

23+

24+inHtml :: Raw -> Canonical

25+inHtml raw =

26+ Canonical Package.html raw

2227

2328

2429toString :: Raw -> String

src/AST/Pattern.hs+16−6

@@ -22,19 +22,29 @@ data Pattern' ann var

2222 | Literal L.Literal

2323

2424

25−type RawPattern =

25+type Raw =

2626 Pattern R.Region Var.Raw

2727

2828

29−type RawPattern' =

29+type Raw' =

3030 Pattern' R.Region Var.Raw

3131

3232

33−type CanonicalPattern =

33+type Canonical =

3434 Pattern R.Region Var.Canonical

3535

3636

37−list :: R.Position -> [RawPattern] -> RawPattern

37+isVar :: String -> Pattern ann var -> Bool

38+isVar name (A.A _ pattern) =

39+ case pattern of

40+ Var pName ->

41+ name == pName

42+

43+ _ ->

44+ False

45+

46+

47+list :: R.Position -> [Raw] -> Raw

3848list end patterns =

3949 case patterns of

4050 [] ->

@@ -44,7 +54,7 @@ list end patterns =

4454 A.at start end (Data (Var.Raw "::") [pattern, list end rest])

4555

4656

47−consMany :: R.Position -> [RawPattern] -> RawPattern

57+consMany :: R.Position -> [Raw] -> Raw

4858consMany end patterns =

4959 let cons hd@(A.A (R.Region start _) _) tl =

5060 A.at start end (Data (Var.Raw "::") [hd, tl])

@@ -52,7 +62,7 @@ consMany end patterns =

5262 foldr1 cons patterns

5363

5464

55−tuple :: [RawPattern] -> RawPattern'

65+tuple :: [Raw] -> Raw'

5666tuple patterns =

5767 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns

5868

src/AST/Type.hs+91−77

@@ -1,16 +1,17 @@

11module AST.Type

22 ( Raw, Raw'(..)

33 , Canonical(..), Aliased(..)

4− , Port(..), getPortType

54 , deepDealias, iteratedDealias, dealias

65 , collectLambdas

7− , tuple

8− ) where

6+ , tuple, cmd, sub

7+ )

8+ where

99

1010import Control.Arrow (second)

1111import Data.Binary

1212import qualified Data.Map as Map

1313

14+import qualified AST.Module.Name as ModuleName

1415import qualified AST.Variable as Var

1516import qualified Reporting.Annotation as A

1617import qualified Reporting.Region as R

@@ -48,24 +49,34 @@ data Aliased t

4849 deriving (Eq, Ord)

4950

5051

51−data Port t

52− = Normal t

53− | Signal { root :: t, arg :: t }

54− deriving (Eq)

5552

56−

57−getPortType :: Port tipe -> tipe

58−getPortType portType =

59− case portType of

60− Normal tipe -> tipe

61− Signal tipe _ -> tipe

53+-- CONSTRUCT USEFUL TYPES

6254

6355

6456tuple :: R.Region -> [Raw] -> Raw

6557tuple region types =

66− let name = Var.Raw ("_Tuple" ++ show (length types))

58+ let

59+ name =

60+ Var.Raw ("_Tuple" ++ show (length types))

6761 in

68− A.A region (RApp (A.A region (RType name)) types)

62+ A.A region (RApp (A.A region (RType name)) types)

63+

64+

65+cmd :: ModuleName.Canonical -> String -> Canonical

66+cmd =

67+ effect Var.cmd

68+

69+

70+sub :: ModuleName.Canonical -> String -> Canonical

71+sub =

72+ effect Var.sub

73+

74+

75+effect :: Var.Canonical -> ModuleName.Canonical -> String -> Canonical

76+effect effectName moduleName tipe =

77+ Lambda

78+ (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])

79+ (App (Type effectName) [Var "msg"])

6980

7081

7182

@@ -76,65 +87,68 @@ deepDealias :: Canonical -> Canonical

7687deepDealias tipe =

7788 case tipe of

7889 Lambda a b ->

79− Lambda (deepDealias a) (deepDealias b)

90+ Lambda (deepDealias a) (deepDealias b)

8091

8192 Var _ ->

82− tipe

93+ tipe

8394

8495 Record fields ext ->

85− Record (map (second deepDealias) fields) (fmap deepDealias ext)

96+ Record (map (second deepDealias) fields) (fmap deepDealias ext)

8697

8798 Aliased _name args tipe' ->

88− deepDealias (dealias args tipe')

99+ deepDealias (dealias args tipe')

89100

90101 Type _ ->

91− tipe

102+ tipe

92103

93104 App f args ->

94− App (deepDealias f) (map deepDealias args)

105+ App (deepDealias f) (map deepDealias args)

95106

96107

97108iteratedDealias :: Canonical -> Canonical

98109iteratedDealias tipe =

99110 case tipe of

100111 Aliased _ args realType ->

101− iteratedDealias (dealias args realType)

112+ iteratedDealias (dealias args realType)

102113

103114 _ ->

104− tipe

115+ tipe

105116

106117

107118dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical

108119dealias args aliasType =

109120 case aliasType of

110121 Holey tipe ->

111− dealiasHelp (Map.fromList args) tipe

122+ dealiasHelp (Map.fromList args) tipe

112123

113124 Filled tipe ->

114− tipe

125+ tipe

115126

116127

117128dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical

118129dealiasHelp typeTable tipe =

119− let go = dealiasHelp typeTable in

120− case tipe of

121− Lambda a b ->

122− Lambda (go a) (go b)

130+ let

131+ go =

132+ dealiasHelp typeTable

133+ in

134+ case tipe of

135+ Lambda a b ->

136+ Lambda (go a) (go b)

123137

124− Var x ->

125− Map.findWithDefault tipe x typeTable

138+ Var x ->

139+ Map.findWithDefault tipe x typeTable

126140

127− Record fields ext ->

128− Record (map (second go) fields) (fmap go ext)

141+ Record fields ext ->

142+ Record (map (second go) fields) (fmap go ext)

129143

130− Aliased original args t' ->

131− Aliased original (map (second go) args) t'

144+ Aliased original args t' ->

145+ Aliased original (map (second go) args) t'

132146

133− Type _ ->

134− tipe

147+ Type _ ->

148+ tipe

135149

136− App f args ->

137− App (go f) (map go args)

150+ App f args ->

151+ App (go f) (map go args)

138152

139153

140154

@@ -145,10 +159,10 @@ collectLambdas :: Canonical -> [Canonical]

145159collectLambdas tipe =

146160 case tipe of

147161 Lambda arg result ->

148− arg : collectLambdas result

162+ arg : collectLambdas result

149163

150164 _ ->

151− [tipe]

165+ [tipe]

152166

153167

154168

@@ -157,49 +171,49 @@ collectLambdas tipe =

157171

158172instance Binary Canonical where

159173 put tipe =

160− case tipe of

161− Lambda t1 t2 ->

162− putWord8 0 >> put t1 >> put t2

174+ case tipe of

175+ Lambda t1 t2 ->

176+ putWord8 0 >> put t1 >> put t2

163177

164− Var x ->

165− putWord8 1 >> put x

178+ Var x ->

179+ putWord8 1 >> put x

166180

167− Type name ->

168− putWord8 2 >> put name

181+ Type name ->

182+ putWord8 2 >> put name

169183

170− App t1 t2 ->

171− putWord8 3 >> put t1 >> put t2

184+ App t1 t2 ->

185+ putWord8 3 >> put t1 >> put t2

172186

173− Record fs ext ->

174− putWord8 4 >> put fs >> put ext

187+ Record fs ext ->

188+ putWord8 4 >> put fs >> put ext

175189

176− Aliased var args t ->

177− putWord8 5 >> put var >> put args >> put t

190+ Aliased var args t ->

191+ putWord8 5 >> put var >> put args >> put t

178192

179− get = do

180− n <- getWord8

181− case n of

182− 0 -> Lambda <$> get <*> get

183− 1 -> Var <$> get

184− 2 -> Type <$> get

185− 3 -> App <$> get <*> get

186− 4 -> Record <$> get <*> get

187− 5 -> Aliased <$> get <*> get <*> get

188− _ -> error "Error reading a valid type from serialized string"

193+ get =

194+ do n <- getWord8

195+ case n of

196+ 0 -> Lambda <$> get <*> get

197+ 1 -> Var <$> get

198+ 2 -> Type <$> get

199+ 3 -> App <$> get <*> get

200+ 4 -> Record <$> get <*> get

201+ 5 -> Aliased <$> get <*> get <*> get

202+ _ -> error "Error reading a valid type from serialized string"

189203

190204

191205instance Binary t => Binary (Aliased t) where

192206 put aliasType =

193− case aliasType of

194− Holey tipe ->

195− putWord8 0 >> put tipe

196−

197− Filled tipe ->

198− putWord8 1 >> put tipe

199−

200− get = do

201− n <- getWord8

202− case n of

203− 0 -> Holey <$> get

204− 1 -> Filled <$> get

205− _ -> error "Error reading a valid type from serialized string"

207+ case aliasType of

208+ Holey tipe ->

209+ putWord8 0 >> put tipe

210+

211+ Filled tipe ->

212+ putWord8 1 >> put tipe

213+

214+ get =

215+ do n <- getWord8

216+ case n of

217+ 0 -> Holey <$> get

218+ 1 -> Filled <$> get

219+ _ -> error "Error reading a valid type from serialized string"

src/AST/Variable.hs+15−10

@@ -70,6 +70,21 @@ inCore home name =

7070 Canonical (Module (ModuleName.inCore home)) name

7171

7272

73+inHtml :: ModuleName.Raw -> String -> Canonical

74+inHtml home name =

75+ Canonical (Module (ModuleName.inHtml home)) name

76+

77+

78+cmd :: Canonical

79+cmd =

80+ inCore ["Platform","Cmd"] "Cmd"

81+

82+

83+sub :: Canonical

84+sub =

85+ inCore ["Platform","Sub"] "Sub"

86+

87+

7388

7489-- VARIABLE RECOGNIZERS

7590

@@ -114,16 +129,6 @@ isTask =

114129 is ["Task"] "Task"

115130

116131

117−isSignal :: Canonical -> Bool

118−isSignal =

119− is ["Signal"] "Signal"

120−

121−

122−isText :: Canonical -> Bool

123−isText =

124− is ["Text"] "Text"

125−

126−

127132isList :: Canonical -> Bool

128133isList v =

129134 v == Canonical BuiltIn "List"

src/Canonicalize.hs+203−239

@@ -1,18 +1,16 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Canonicalize (module') where

23

34import qualified Data.List as List

45import qualified Data.Map as Map

56import qualified Data.Maybe as Maybe

67import qualified Data.Set as Set

7−import qualified Data.Traversable as T

88import qualified Data.Foldable as T

99

10−import AST.Expression.General (Expr'(..), dummyLet)

11−import AST.Module (Body(..))

10+import AST.Expression.General (Expr'(..))

1211import Elm.Utils ((|>))

1312

1413import qualified AST.Declaration as D

15−import qualified AST.Expression.General as E

1614import qualified AST.Expression.Valid as Valid

1715import qualified AST.Expression.Canonical as Canonical

1816import qualified AST.Module as Module

@@ -20,144 +18,132 @@ import qualified AST.Module.Name as ModuleName

2018import qualified AST.Pattern as P

2119import qualified AST.Type as Type

2220import qualified AST.Variable as Var

23−import qualified Docs.AST as Docs

21+import qualified Canonicalize.Body as Body

22+import qualified Canonicalize.Effects as Effects

23+import qualified Canonicalize.Environment as Env

24+import qualified Canonicalize.Setup as Setup

25+import qualified Canonicalize.Type as Canon

26+import qualified Canonicalize.Variable as Canon

2427import qualified Docs.Centralize as Docs

2528import qualified Reporting.Annotation as A

2629import qualified Reporting.Error as Error

2730import qualified Reporting.Error.Canonicalize as CError

2831import qualified Reporting.Error.Helpers as ErrorHelp

2932import qualified Reporting.Region as Region

30−import qualified Reporting.Result as R

33+import qualified Reporting.Render.Type as RenderType

34+import qualified Reporting.Result as Result

3135import qualified Reporting.Warning as Warning

32−import qualified Canonicalize.Declaration as Decls

33−import qualified Canonicalize.Environment as Env

34−import qualified Canonicalize.Port as Port

35−import qualified Canonicalize.Result as Result

36−import qualified Canonicalize.Setup as Setup

37−import qualified Canonicalize.Sort as Sort

38−import qualified Canonicalize.Type as Canonicalize

39−import qualified Canonicalize.Variable as Canonicalize

36+

37+

38+

39+type Result a =

40+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a

4041

4142

4243-- MODULES

4344

45+

4446module'

4547 :: [ModuleName.Canonical]

4648 -> Module.Interfaces

47− -> Module.ValidModule

48− -> R.Result Warning.Warning Error.Error Module.CanonicalModule

49−module' canonicalImports interfaces modul =

49+ -> Module.Valid

50+ -> Result Module.Canonical

51+module' allCanonicalImports interfaces modul =

5052 let

53+ (Module.Valid docs exports imports decls effects) =

54+ Module.info modul

55+

5156 importDict =

52− canonicalImports

57+ allCanonicalImports

5358 |> map (\cName -> (ModuleName._module cName, cName))

5459 |> Map.fromList

5560

56− (Result.Result uses rawResults) =

57− moduleHelp importDict interfaces modul

58− in

59− case rawResults of

60− Result.Ok (env, almostCanonicalModule) ->

61− R.addDealiaser (Env.toDealiaser env) $

62− filterImports uses almostCanonicalModule

61+ (Result.Result uses warnings rawResults) =

62+ do env <- Setup.environment importDict interfaces modul

6363

64− Result.Err msgs ->

65− R.throwMany (map (A.map Error.Canonicalize) msgs)

64+ (,,,) env

65+ <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports

66+ <*> canonicalizeDecls env decls

67+ <*> Effects.canonicalize env effects

68+ in

69+ case rawResults of

70+ Result.Err errors ->

71+ Result.mapError Error.Canonicalize $

72+ Result.Result Result.None warnings (Result.Err errors)

6673

74+ Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->

75+ let

76+ (D.Decls _ unions aliases infixes) =

77+ canonicalDecls

6778

68−type AlmostCanonicalModule =

69− Module.Module

70− Docs.Centralized

71− ([Module.DefaultImport], [Module.UserImport])

72− [Var.Value]

73− (Module.Body Canonical.Expr)

79+ centralizedDocs =

80+ A.map (fmap (Docs.centralize canonicalDecls)) docs

7481

82+ typeToPair (A.A _ (D.Type name args body)) =

83+ ( name, (args, body) )

7584

76−moduleHelp

77− :: Map.Map ModuleName.Raw ModuleName.Canonical

78− -> Module.Interfaces

79− -> Module.ValidModule

80− -> Result.ResultErr (Env.Environment, AlmostCanonicalModule)

81−moduleHelp importDict interfaces modul@(Module.Module _ _ comment exports _ decls) =

82− canonicalModule

83− <$> canonicalDeclsResult

84− <*> resolveExports locals exports

85− where

86− canonicalModule (env, canonicalDecls) canonicalExports =

87− (,) env $

88− modul

89− { Module.docs = A.map (fmap (Docs.centralize canonicalDecls)) comment

90− , Module.exports = canonicalExports

91− , Module.body = body canonicalDecls

92− }

93−

94− locals :: [Var.Value]

95− locals =

96− concatMap declToValue decls

97−

98− canonicalDeclsResult =

99− Setup.environment importDict interfaces modul

100− `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

101−

102− body :: [D.CanonicalDecl] -> Module.Body Canonical.Expr

103− body decls =

104− let nakedDecls = map A.drop decls

85+ program =

86+ Body.flatten (Module.name modul) canonicalDecls canonicalEffects

10587 in

106− Module.Body

107− { program =

108− let expr = Decls.toExpr (Module.name modul) decls

109− in

110− Sort.definitions (dummyLet expr)

111−

112− , types =

113− Map.empty

114−

115− , datatypes =

116− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- nakedDecls ]

88+ do canonicalImports <- filterImports uses imports

89+ Result.accumulate (Result.One (Env.toDealiaser env)) $

90+ modul {

91+ Module.info =

92+ Module.Info

93+ { Module.docs = centralizedDocs

94+ , Module.exports = canonicalExports

95+ , Module.imports = canonicalImports

96+ , Module.program = program

97+ , Module.types = Map.empty

98+ , Module.fixities = infixes

99+ , Module.aliases = Map.fromList (map typeToPair aliases)

100+ , Module.unions = Map.fromList (map typeToPair unions)

101+ , Module.effects = canonicalEffects

102+ }

103+ }

117104

118− , fixities =

119− [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]

120−

121− , aliases =

122− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- nakedDecls ]

123−

124− , ports =

125− [ E.portName impl | D.Port (D.CanonicalPort impl) <- nakedDecls ]

126− }

127105

128106

129107-- IMPORTS

130108

109+

131110filterImports

132111 :: Set.Set ModuleName.Raw

133− -> AlmostCanonicalModule

134− -> R.Result Warning.Warning e Module.CanonicalModule

135−filterImports uses modul@(Module.Module _ _ _ _ (defaults, imports) _) =

136− do reducedImports <-

137− Maybe.catMaybes <$> T.traverse checkImport imports

138−

139− return $ modul

140− { Module.imports =

141− Set.toList (Set.fromList (map fst defaults ++ reducedImports))

142− }

143− where

112+ -> ([Module.DefaultImport], [Module.UserImport])

113+ -> Result [ModuleName.Raw]

114+filterImports uses (defaults, imports) =

115+ let

144116 checkImport (A.A region (name, _method)) =

145117 if Set.member name uses then

146− return (Just name)

118+ return (Just name)

119+

147120 else

148− do R.warn region (Warning.UnusedImport name)

149− return Nothing

121+ Result.warn region (Warning.UnusedImport name) Nothing

122+ in

123+ do reducedImports <-

124+ Maybe.catMaybes <$> traverse checkImport imports

125+

126+ return $

127+ Set.toList (Set.fromList (map fst defaults ++ reducedImports))

128+

129+

130+

131+-------- CANONICALIZATION --------

132+

133+

134+type CResult a =

135+ Canon.Result a

136+

150137

151138

152139-- EXPORTS

153140

154−resolveExports

155− :: [Var.Value]

156− -> Var.Listing (A.Located Var.Value)

157− -> Result.ResultErr [Var.Value]

141+

142+resolveExports :: [Var.Value] -> Var.Listing (A.Located Var.Value) -> CResult [Var.Value]

158143resolveExports fullList (Var.Listing partialList open) =

159144 if open then

160145 Result.ok fullList

146+

161147 else

162148 let

163149 (allValues, allAliases, allAdts) =

@@ -170,17 +156,13 @@ resolveExports fullList (Var.Listing partialList open) =

170156 map fst allAdts

171157 in

172158 (\xs ys zs _ -> xs ++ ys ++ zs)

173− <$> T.traverse (getValueExport allValues (Set.fromList allValues)) values

174− <*> (concat <$> T.traverse (getAliasExport allValues allAliases adtTypes) aliases)

175− <*> T.traverse (getAdtExport allAdts adtTypes) adts

159+ <$> traverse (getValueExport allValues (Set.fromList allValues)) values

160+ <*> (concat <$> traverse (getAliasExport allValues allAliases adtTypes) aliases)

161+ <*> traverse (getAdtExport allAdts adtTypes) adts

176162 <*> allUnique partialList

177163

178164

179−getValueExport

180− :: [String]

181− -> Set.Set String

182− -> A.Located String

183− -> Result.ResultErr Var.Value

165+getValueExport :: [String] -> Set.Set String -> A.Located String -> CResult Var.Value

184166getValueExport allValues allValuesSet (A.A region name) =

185167 if Set.member name allValuesSet then

186168 Result.ok (Var.Value name)

@@ -188,12 +170,7 @@ getValueExport allValues allValuesSet (A.A region name) =

188170 manyNotFound region [name] allValues

189171

190172

191−getAliasExport

192− :: [String]

193− -> [String]

194− -> [String]

195− -> A.Located String

196− -> Result.ResultErr [Var.Value]

173+getAliasExport :: [String] -> [String] -> [String] -> A.Located String -> CResult [Var.Value]

197174getAliasExport allValues allAliases adtTypes (A.A region alias) =

198175 if alias `elem` allAliases then

199176

@@ -213,7 +190,7 @@ getAdtExport

213190 :: [(String, Var.Listing String)]

214191 -> [String]

215192 -> A.Located (String, Var.Listing String)

216− -> Result.ResultErr Var.Value

193+ -> CResult Var.Value

217194getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =

218195 case List.lookup name allAdts of

219196 Nothing ->

@@ -230,9 +207,9 @@ getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =

230207 manyNotFound region unfoundCtors allCtors

231208

232209

233−manyNotFound :: Region.Region -> [String] -> [String] -> Result.ResultErr a

210+manyNotFound :: Region.Region -> [String] -> [String] -> CResult a

234211manyNotFound region nameList possibilities =

235− Result.errors (map (notFound region possibilities) nameList)

212+ Result.throwMany (map (notFound region possibilities) nameList)

236213

237214

238215notFound :: Region.Region -> [String] -> String -> A.Located CError.Error

@@ -241,7 +218,7 @@ notFound region possibilities name =

241218 ErrorHelp.nearbyNames id name possibilities

242219

243220

244−allUnique :: [A.Located Var.Value] -> Result.ResultErr ()

221+allUnique :: [A.Located Var.Value] -> CResult ()

245222allUnique statedExports =

246223 let

247224 valueToString value =

@@ -256,16 +233,46 @@ allUnique statedExports =

256233 isUnique value allRegions =

257234 case allRegions of

258235 region : _ : _ ->

259− Result.err (A.A region (CError.DuplicateExport (valueToString value)))

236+ Result.throw region (CError.DuplicateExport (valueToString value))

260237

261238 _ ->

262239 Result.ok ()

263240 in

264− T.traverse_ id (Map.mapWithKey isUnique locations)

241+ T.sequenceA_ (Map.mapWithKey isUnique locations)

242+

243+

244+

245+-- CONVERSIONS

246+

247+

248+declsToValues :: D.Valid -> [Var.Value]

249+declsToValues (D.Decls defs unions aliases _) =

250+ let

251+ fromDef (A.A _ def) =

252+ map Var.Value (P.boundVarList (Valid.getPattern def))

253+

254+ fromUnion (A.A _ (D.Type name _ ctors)) =

255+ Var.Union name (Var.Listing (map fst ctors) False)

256+

257+ fromAlias (A.A _ (D.Type name _ tipe)) =

258+ case tipe of

259+ A.A _ (Type.RRecord _ Nothing) ->

260+ [ Var.Alias name, Var.Value name ]

261+

262+ _ ->

263+ [ Var.Alias name ]

264+ in

265+ concat

266+ [ map fromUnion unions

267+ , concatMap fromAlias aliases

268+ , concatMap fromDef defs

269+ ]

270+

265271

266272

267273-- GROUPING VALUES

268274

275+

269276maybeUnzip3 :: [(Maybe a, Maybe b, Maybe c)] -> ([a],[b],[c])

270277maybeUnzip3 tuples =

271278 let (as, bs, cs) = unzip3 tuples

@@ -307,90 +314,52 @@ splitLocatedValue (A.A region value) =

307314 (Nothing, Nothing, Just (A.A region (name, listing)))

308315

309316

317+

310318-- DECLARATIONS

311319

312−declToValue :: D.ValidDecl -> [Var.Value]

313−declToValue (A.A _ decl) =

314− case decl of

315− D.Definition (Valid.Definition pattern _ _) ->

316− map Var.Value (P.boundVarList pattern)

317320

318− D.Datatype name _tvs ctors ->

319− [ Var.Union name (Var.Listing (map fst ctors) False) ]

321+canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical

322+canonicalizeDecls env (D.Decls defs unions aliases infixes) =

323+ let

324+ annTraverse canEntry entries =

325+ traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

320326

321− D.TypeAlias name _ tipe ->

322− case tipe of

323− A.A _ (Type.RRecord _ Nothing) ->

324− [ Var.Alias name, Var.Value name ]

327+ canonicalizeDef (Valid.Def pat expr typ) =

328+ Canonical.Def Canonical.dummyFacts

329+ <$> canonicalizePattern env pat

330+ <*> canonicalizeExpr env expr

331+ <*> traverse (canonicalizeRegionType env) typ

325332

326− _ ->

327− [ Var.Alias name ]

333+ canonicalizeArgs (ctor, args) =

334+ (,) ctor <$> traverse (Canon.tipe env) args

328335

329− _ -> []

336+ canonicalizeUnion (D.Type name tvars ctors) =

337+ D.Type name tvars <$> traverse canonicalizeArgs ctors

330338

339+ canonicalizeAlias (D.Type name tvars alias) =

340+ D.Type name tvars <$> Canon.tipe env alias

341+ in

342+ D.Decls

343+ <$> annTraverse canonicalizeDef defs

344+ <*> annTraverse canonicalizeUnion unions

345+ <*> annTraverse canonicalizeAlias aliases

346+ <*> pure infixes

331347

332−declaration

333− :: Env.Environment

334− -> D.ValidDecl

335− -> Result.ResultErr D.CanonicalDecl

336−declaration env (A.A ann@(region,_) decl) =

337− A.A ann <$>

338− case decl of

339− D.Definition (Valid.Definition pat expr typ) ->

340− D.Definition <$> (

341− Canonical.Definition Canonical.dummyFacts

342− <$> pattern env pat

343− <*> expression env expr

344− <*> T.traverse (regionType env) typ

345− )

346−

347− D.Datatype name tvars ctors ->

348− D.Datatype name tvars <$> T.traverse canonicalize' ctors

349− where

350− canonicalize' (ctor,args) =

351− (,) ctor <$> T.traverse (Canonicalize.tipe env) args

352−

353− D.TypeAlias name tvars expanded ->

354− D.TypeAlias name tvars

355− <$> Canonicalize.tipe env expanded

356−

357− D.Port validPort ->

358− Result.addModule ["Native","Port"] $

359− Result.addModule ["Native","Json"] $

360− case validPort of

361− D.In name tipe ->

362− Canonicalize.tipe env tipe

363− `Result.andThen` \canonicalType ->

364− D.Port <$> Port.check region name Nothing canonicalType

365−

366− D.Out name expr tipe ->

367− let exprTypeResult =

368− (,)

369− <$> expression env expr

370− <*> Canonicalize.tipe env tipe

371− in

372− exprTypeResult

373− `Result.andThen` \(expr', tipe') ->

374− D.Port <$> Port.check region name (Just expr') tipe'

375−

376− D.Fixity assoc prec op ->

377− Result.ok (D.Fixity assoc prec op)

378−

379−

380−regionType

348+

349+canonicalizeRegionType

381350 :: Env.Environment

382351 -> Type.Raw

383− -> Result.ResultErr (A.Located Type.Canonical)

384−regionType env typ@(A.A region _) =

385− A.A region <$> Canonicalize.tipe env typ

352+ -> CResult (A.Located Type.Canonical)

353+canonicalizeRegionType env typ@(A.A region _) =

354+ A.A region <$> Canon.tipe env typ

386355

387356

388−expression

357+canonicalizeExpr

389358 :: Env.Environment

390359 -> Valid.Expr

391− -> Result.ResultErr Canonical.Expr

392−expression env (A.A region validExpr) =

393− let go = expression env

360+ -> CResult Canonical.Expr

361+canonicalizeExpr env (A.A region validExpr) =

362+ let go = canonicalizeExpr env

394363 in

395364 A.A region <$>

396365 case validExpr of

@@ -406,94 +375,89 @@ expression env (A.A region validExpr) =

406375 Update record fields ->

407376 Update

408377 <$> go record

409− <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

378+ <*> traverse (\(field,expr) -> (,) field <$> go expr) fields

410379

411380 Record fields ->

412381 Record

413− <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

382+ <$> traverse (\(field,expr) -> (,) field <$> go expr) fields

414383

415384 Binop (Var.Raw op) leftExpr rightExpr ->

416385 Binop

417− <$> Canonicalize.variable region env op

386+ <$> Canon.variable region env op

418387 <*> go leftExpr

419388 <*> go rightExpr

420389

421390 Lambda arg body ->

422− let env' = Env.addPattern arg env

391+ let

392+ env' =

393+ Env.addPattern arg env

423394 in

424− Lambda <$> pattern env' arg <*> expression env' body

395+ Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body

425396

426397 App func arg ->

427398 App <$> go func <*> go arg

428399

429400 If branches finally ->

430401 If

431− <$> T.traverse go' branches

402+ <$> traverse go' branches

432403 <*> go finally

433404 where

434405 go' (condition, branch) =

435406 (,) <$> go condition <*> go branch

436407

437− Let defs body ->

438− Let <$> T.traverse rename' defs <*> expression env' body

408+ Let defs expr ->

409+ Let <$> traverse rename' defs <*> canonicalizeExpr env' expr

439410 where

440411 env' =

441− foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs

412+ foldr Env.addPattern env (map Valid.getPattern defs)

442413

443− rename' (Valid.Definition p body mtipe) =

444− Canonical.Definition Canonical.dummyFacts

445− <$> pattern env' p

446− <*> expression env' body

447− <*> T.traverse (regionType env') mtipe

414+ rename' (Valid.Def p body mtipe) =

415+ Canonical.Def Canonical.dummyFacts

416+ <$> canonicalizePattern env' p

417+ <*> canonicalizeExpr env' body

418+ <*> traverse (canonicalizeRegionType env') mtipe

448419

449420 Var (Var.Raw x) ->

450− Var <$> Canonicalize.variable region env x

421+ Var <$> Canon.variable region env x

451422

452423 Data name exprs ->

453− Data name <$> T.traverse go exprs

424+ Data name <$> traverse go exprs

454425

455426 ExplicitList exprs ->

456− ExplicitList <$> T.traverse go exprs

427+ ExplicitList <$> traverse go exprs

457428

458429 Case expr cases ->

459− Case <$> go expr <*> T.traverse branch cases

430+ Case <$> go expr <*> traverse branch cases

460431 where

461432 branch (ptrn, brnch) =

462− (,) <$> pattern env ptrn

463− <*> expression (Env.addPattern ptrn env) brnch

464−

465− Port impl ->

466− let portType pt =

467− case pt of

468− Type.Normal t ->

469− Type.Normal

470− <$> Canonicalize.tipe env t

471−

472− Type.Signal root arg ->

473− Type.Signal

474− <$> Canonicalize.tipe env root

475− <*> Canonicalize.tipe env arg

476− in

477− Port <$>

478− case impl of

479− E.In name tipe ->

480− E.In name <$> portType tipe

433+ (,)

434+ <$> canonicalizePattern env ptrn

435+ <*> canonicalizeExpr (Env.addPattern ptrn env) brnch

436+

437+ Cmd moduleName ->

438+ Result.ok (Cmd moduleName)

439+

440+ Sub moduleName ->

441+ Result.ok (Sub moduleName)

481442

482− E.Out name expr tipe ->

483− E.Out name <$> go expr <*> portType tipe

443+ OutgoingPort name tipe ->

444+ OutgoingPort name <$> Canon.tipe env tipe

484445

485− E.Task name expr tipe ->

486− E.Task name <$> go expr <*> portType tipe

446+ IncomingPort name tipe ->

447+ IncomingPort name <$> Canon.tipe env tipe

448+

449+ Program _ _ ->

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

451+

452+ SaveEnv moduleName effects ->

453+ Result.ok (SaveEnv moduleName effects)

487454

488455 GLShader uid src tipe ->

489456 Result.ok (GLShader uid src tipe)

490457

491458

492−pattern

493− :: Env.Environment

494− -> P.RawPattern

495− -> Result.ResultErr P.CanonicalPattern

496−pattern env (A.A region ptrn) =

459+canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical

460+canonicalizePattern env (A.A region ptrn) =

497461 A.A region <$>

498462 case ptrn of

499463 P.Var x ->

@@ -509,9 +473,9 @@ pattern env (A.A region ptrn) =

509473 Result.ok P.Anything

510474

511475 P.Alias x p ->

512− P.Alias x <$> pattern env p

476+ P.Alias x <$> canonicalizePattern env p

513477

514478 P.Data (Var.Raw name) patterns ->

515479 P.Data

516− <$> Canonicalize.pvar region env name (length patterns)

517− <*> T.traverse (pattern env) patterns

480+ <$> Canon.pvar region env name (length patterns)

481+ <*> traverse (canonicalizePattern env) patterns

src/Canonicalize/Body.hsnew file+170

@@ -0,0 +1,170 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Canonicalize.Body (flatten) where

3+

4+import qualified Data.Maybe as Maybe

5+

6+import qualified AST.Declaration as Decl

7+import qualified AST.Effects as Effects

8+import qualified AST.Expression.General as E

9+import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Module.Name as ModuleName

11+import qualified AST.Pattern as P

12+import qualified AST.Type as Type

13+import qualified AST.Variable as Var

14+import qualified Canonicalize.Sort as Sort

15+import qualified Reporting.Annotation as A

16+import qualified Reporting.Region as R

17+

18+

19+

20+flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr

21+flatten moduleName (Decl.Decls defs unions aliases _) effects =

22+ let

23+ allDefs =

24+ concat

25+ [ concatMap (unionToDefs moduleName) unions

26+ , Maybe.mapMaybe (aliasToDefs moduleName) aliases

27+ , effectsToDefs moduleName effects

28+ , map A.drop defs

29+ ]

30+

31+ loc =

32+ A.A (error "this annotation should never be needed")

33+ in

34+ Sort.definitions $ loc $

35+ E.Let allDefs (loc $ E.SaveEnv moduleName effects)

36+

37+

38+

39+-- TYPES TO DEFS

40+

41+

42+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]

43+unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

44+ let

45+ tagToDef (tag, tipes) =

46+ let

47+ vars =

48+ take (length tipes) infiniteArgs

49+

50+ tbody =

51+ Type.App

52+ (Type.Type (Var.fromModule moduleName name))

53+ (map Type.Var tvars)

54+

55+ body =

56+ A.A region $

57+ E.Data tag (map (A.A region . E.localVar) vars)

58+ in

59+ definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)

60+ in

61+ map tagToDef constructors

62+

63+

64+aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe Canonical.Def

65+aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =

66+ case tipe of

67+ Type.Record fields Nothing ->

68+ let

69+ resultType =

70+ Type.Aliased

71+ (Var.fromModule moduleName name)

72+ (zip tvars (map Type.Var tvars))

73+ (Type.Holey tipe)

74+

75+ args =

76+ map snd fields

77+

78+ vars =

79+ take (length args) infiniteArgs

80+

81+ record =

82+ A.A region $

83+ E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))

84+ in

85+ Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)

86+

87+ _ ->

88+ Nothing

89+

90+

91+infiniteArgs :: [String]

92+infiniteArgs =

93+ map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

94+

95+

96+buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr

97+buildFunction vars body@(A.A ann _) =

98+ foldr

99+ (\pattern expr -> A.A ann (E.Lambda pattern expr))

100+ body

101+ (map (A.A ann . P.Var) vars)

102+

103+

104+definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def

105+definition name expr@(A.A ann _) region tipe =

106+ Canonical.Def

107+ Canonical.dummyFacts

108+ (A.A ann (P.Var name))

109+ expr

110+ (Just (A.A region tipe))

111+

112+

113+

114+-- EFFECTS

115+

116+

117+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]

118+effectsToDefs moduleName effects =

119+ case effects of

120+ Effects.None ->

121+ []

122+

123+ Effects.Port ports ->

124+ map portToDef ports

125+

126+ Effects.Manager _ info ->

127+ let

128+ cmdToDef (A.A region name) =

129+ definition

130+ "command"

131+ (A.A region (E.Cmd moduleName))

132+ region

133+ (Type.cmd moduleName name)

134+

135+ subToDef (A.A region name) =

136+ definition

137+ "subscription"

138+ (A.A region (E.Sub moduleName))

139+ region

140+ (Type.sub moduleName name)

141+ in

142+ case Effects._managerType info of

143+ Effects.CmdManager cmd ->

144+ [ cmdToDef cmd

145+ ]

146+

147+ Effects.SubManager sub ->

148+ [ subToDef sub

149+ ]

150+

151+ Effects.FxManager cmd sub ->

152+ [ cmdToDef cmd

153+ , subToDef sub

154+ ]

155+

156+

157+portToDef :: A.Commented Effects.PortCanonical -> Canonical.Def

158+portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =

159+ definition name (A.A region (toPortExpr name kind)) region tipe

160+

161+

162+toPortExpr :: String -> Effects.Kind -> Canonical.Expr'

163+toPortExpr name kind =

164+ case kind of

165+ Effects.Outgoing tipe ->

166+ E.OutgoingPort name tipe

167+

168+ Effects.Incoming tipe ->

169+ E.IncomingPort name tipe

170+

src/Canonicalize/Declaration.hsdeleted−100

@@ -1,100 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Declaration (toExpr) where

3−

4−import qualified AST.Declaration as D

5−import qualified AST.Expression.General as E

6−import qualified AST.Expression.Canonical as Canonical

7−import qualified AST.Module.Name as ModuleName

8−import qualified AST.Pattern as P

9−import qualified AST.Type as T

10−import qualified AST.Variable as Var

11−import qualified Reporting.Annotation as A

12−import qualified Reporting.Region as R

13−

14−

15−toExpr :: ModuleName.Canonical -> [D.CanonicalDecl] -> [Canonical.Def]

16−toExpr moduleName decls =

17− concatMap (toDefs moduleName) decls

18−

19−

20−toDefs :: ModuleName.Canonical -> D.CanonicalDecl -> [Canonical.Def]

21−toDefs moduleName (A.A (region,_) decl) =

22− let

23− typeVar =

24− Var.fromModule moduleName

25−

26− loc expr =

27− A.A region expr

28− in

29− case decl of

30− D.Definition def ->

31− [def]

32−

33− D.Datatype name tvars constructors ->

34− concatMap toDefs' constructors

35− where

36− toDefs' (ctor, tipes) =

37− let vars = take (length tipes) infiniteArgs

38− tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

39− body = loc . E.Data ctor $ map (loc . E.localVar) vars

40− in

41− [ definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes) ]

42−

43− D.TypeAlias name tvars tipe@(T.Record fields Nothing) ->

44− [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

45− where

46− result =

47− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

48−

49− args =

50− map snd fields

51−

52− vars =

53− take (length args) infiniteArgs

54−

55− record =

56− loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))

57−

58− -- Type aliases must be added to an extended equality dictionary,

59− -- but they do not require any basic constraints.

60− D.TypeAlias _ _ _ ->

61− []

62−

63− D.Port (D.CanonicalPort impl) ->

64− let body = loc (E.Port impl)

65− in

66− case impl of

67− E.In name tipe ->

68− [ definition name body region (T.getPortType tipe) ]

69−

70− E.Out name _expr tipe ->

71− [ definition name body region (T.getPortType tipe) ]

72−

73− E.Task name _expr tipe ->

74− [ definition name body region (T.getPortType tipe) ]

75−

76− -- no constraints are needed for fixity declarations

77− D.Fixity _ _ _ ->

78− []

79−

80−

81−infiniteArgs :: [String]

82−infiniteArgs =

83− map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

84−

85−

86−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

87−buildFunction body@(A.A ann _) vars =

88− foldr

89− (\pattern expr -> A.A ann (E.Lambda pattern expr))

90− body

91− (map (A.A ann . P.Var) vars)

92−

93−

94−definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def

95−definition name expr@(A.A ann _) region tipe =

96− Canonical.Definition

97− Canonical.dummyFacts

98− (A.A ann (P.Var name))

99− expr

100− (Just (A.A region tipe))

src/Canonicalize/Effects.hsnew file+137

@@ -0,0 +1,137 @@

1+module Canonicalize.Effects (canonicalize, toValues, checkPortType) where

2+

3+import qualified Data.Foldable as F

4+import qualified Data.Traversable as T

5+

6+import qualified AST.Effects as Effects

7+import qualified AST.Type as T

8+import qualified AST.Variable as Var

9+import qualified Reporting.Annotation as A

10+import qualified Reporting.Error.Canonicalize as Error

11+import qualified Reporting.Region as R

12+import qualified Reporting.Result as Result

13+import qualified Canonicalize.Environment as Env

14+import qualified Canonicalize.Type as Canonicalize

15+import Canonicalize.Variable (Result)

16+

17+

18+

19+-- TO EXPORT VALUES

20+

21+

22+toValues :: Effects.Raw -> [Var.Value]

23+toValues effects =

24+ case effects of

25+ Effects.None ->

26+ []

27+

28+ Effects.Manager _ _ ->

29+ []

30+

31+ Effects.Port ports ->

32+ map (Var.Value . Effects._rawName . A.drop) ports

33+

34+

35+

36+-- CANONICALIZE

37+

38+

39+canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical

40+canonicalize env effects =

41+ case effects of

42+ Effects.None ->

43+ Result.ok Effects.None

44+

45+ Effects.Manager _ info ->

46+ Result.ok (Effects.Manager (Env.getPackage env) info)

47+

48+ Effects.Port rawPorts ->

49+ Effects.Port <$> T.traverse (canonicalizeRawPort env) rawPorts

50+

51+

52+canonicalizeRawPort

53+ :: Env.Environment

54+ -> A.Commented Effects.PortRaw

55+ -> Result (A.Commented Effects.PortCanonical)

56+canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =

57+ do tipe <- Canonicalize.tipe env rawType

58+ kind <- figureOutKind (fst ann) name tipe

59+ Result.ok (A.A ann (Effects.PortCanonical name kind tipe))

60+

61+

62+figureOutKind :: R.Region -> String -> T.Canonical -> Result Effects.Kind

63+figureOutKind region name rootType =

64+ case T.deepDealias rootType of

65+ T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])

66+ | effect == Var.cmd ->

67+ pure (Effects.Outgoing outgoingType)

68+ <* checkPortType (makeError region name) outgoingType

69+

70+ T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])

71+ | effect == Var.sub && msg1 == msg2 ->

72+ pure (Effects.Incoming incomingType)

73+ <* checkPortType (makeError region name) incomingType

74+

75+ _ ->

76+ Result.throw region (error "TODO - bad overall type")

77+

78+

79+makeError :: R.Region -> String -> T.Canonical -> Maybe String -> A.Located Error.Error

80+makeError region name tipe maybeMessage =

81+ A.A region (Error.port name tipe maybeMessage)

82+

83+

84+

85+-- CHECK INCOMING AND OUTGOING TYPES

86+

87+

88+checkPortType

89+ :: (Monoid i)

90+ => (T.Canonical -> Maybe String -> A.Located e)

91+ -> T.Canonical

92+ -> Result.Result i w e ()

93+checkPortType makeError tipe =

94+ let

95+ check =

96+ checkPortType makeError

97+

98+ throw maybeMsg =

99+ Result.throwMany [makeError tipe maybeMsg]

100+ in

101+ case tipe of

102+ T.Aliased _ args aliasedType ->

103+ check (T.dealias args aliasedType)

104+

105+ T.Type name ->

106+ if Var.isJson name || Var.isPrimitive name || Var.isTuple name then

107+ return ()

108+

109+ else

110+ throw Nothing

111+

112+ T.App name [] ->

113+ check name

114+

115+ T.App (T.Type name) [arg]

116+ | Var.isMaybe name -> check arg

117+ | Var.isArray name -> check arg

118+ | Var.isList name -> check arg

119+

120+ T.App (T.Type name) args

121+ | Var.isTuple name ->

122+ F.traverse_ check args

123+

124+ T.App _ _ ->

125+ throw Nothing

126+

127+ T.Var _ ->

128+ throw (Just "free type variable")

129+

130+ T.Lambda _ _ ->

131+ throw (Just "function")

132+

133+ T.Record _ (Just _) ->

134+ throw (Just "extended record")

135+

136+ T.Record fields Nothing ->

137+ F.traverse_ (\(k,v) -> (,) k <$> check v) fields

src/Canonicalize/Environment.hs+38−18

@@ -1,25 +1,34 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Environment where

2+module Canonicalize.Environment

3+ ( Environment(..)

4+ , getPackage

5+ , insert

6+ , Patch(..), fromPatches, addPattern

7+ , builtinPatches

8+ , toDealiaser

9+ )

10+ where

311

412import qualified Data.List as List

513import qualified Data.Map as Map

614import qualified Data.Maybe as Maybe

715import qualified Data.Set as Set

816

9−import AST.Expression.General (saveEnvName)

1017import qualified AST.Module.Name as ModuleName

1118import qualified AST.Pattern as P

1219import qualified AST.Type as Type

1320import qualified AST.Variable as Var

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

21+import qualified Elm.Package as Pkg

22+

1523

1624

1725-- ENVIRONMENT

1826

27+

1928data Environment = Env

2029 { _home :: ModuleName.Canonical

2130 , _values :: Dict Var.Canonical

22− , _adts :: Dict Var.Canonical

31+ , _unions :: Dict Var.Canonical

2332 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

2433 , _patterns :: Dict (Var.Canonical, Int)

2534 }

@@ -31,21 +40,27 @@ type Dict a =

3140

3241fromPatches :: ModuleName.Canonical -> [Patch] -> Environment

3342fromPatches moduleName patches =

34− addPatches

35− patches

36− (Env moduleName Map.empty Map.empty Map.empty Map.empty)

43+ addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty)

3744

3845

3946addPattern :: P.Pattern ann var -> Environment -> Environment

4047addPattern pattern env =

41− let patches =

42− map (\x -> Value x (Var.local x)) (P.boundVarList pattern)

48+ let

49+ patches =

50+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)

4351 in

44− addPatches patches env

52+ addPatches patches env

53+

54+

55+getPackage :: Environment -> Pkg.Name

56+getPackage env =

57+ ModuleName._package (_home env)

58+

4559

4660

4761-- PATCHES

4862

63+

4964data Patch

5065 = Value String Var.Canonical

5166 | Union String Var.Canonical

@@ -53,8 +68,10 @@ data Patch

5368 | Pattern String (Var.Canonical, Int)

5469

5570

71+

5672-- ADD PATCH TO ENVIRONMENT

5773

74+

5875addPatches :: [Patch] -> Environment -> Environment

5976addPatches patches env =

6077 List.foldl' (flip addPatch) env patches

@@ -67,7 +84,7 @@ addPatch patch env =

6784 env { _values = insert name var (_values env) }

6885

6986 Union name var ->

70− env { _adts = insert name var (_adts env) }

87+ env { _unions = insert name var (_unions env) }

7188

7289 Alias name var ->

7390 env { _aliases = insert name var (_aliases env) }

@@ -81,12 +98,14 @@ insert key value =

8198 Map.insertWith Set.union key (Set.singleton value)

8299

83100

101+

84102-- PATCH HELPERS

85103

104+

86105builtinPatches :: [Patch]

87106builtinPatches =

88107 concat

89− [ map (patch Value) (tupleNames ++ [saveEnvName])

108+ [ map (patch Value) tupleNames

90109 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])

91110 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])

92111 ]

@@ -108,12 +127,14 @@ builtinPatches =

108127 ("_Tuple" ++ show n, n)

109128

110129

130+

111131-- TO TYPE DEALIASER

112132

133+

113134toDealiaser :: Environment -> Map.Map String String

114−toDealiaser (Env _ _ adts aliases _) =

135+toDealiaser (Env _ _ unions aliases _) =

115136 let

116− dealiasAdt (localName, canonicalSet) =

137+ dealiasUnion (localName, canonicalSet) =

117138 case Set.toList canonicalSet of

118139 [canonicalName] ->

119140 Just (Var.toString canonicalName, localName)

@@ -127,8 +148,8 @@ toDealiaser (Env _ _ adts aliases _) =

127148 _ ->

128149 Nothing

129150

130− adtPairs =

131− Maybe.mapMaybe dealiasAdt (Map.toList adts)

151+ unionPairs =

152+ Maybe.mapMaybe dealiasUnion (Map.toList unions)

132153

133154 aliasPairs =

134155 Maybe.mapMaybe dealiasAlias (Map.toList aliases)

@@ -136,5 +157,4 @@ toDealiaser (Env _ _ adts aliases _) =

136157 add (key,value) dict =

137158 Map.insertWith (\v v' -> if length v < length v' then v else v') key value dict

138159 in

139− adtPairs ++ aliasPairs

140− |> foldr add Map.empty

160+ foldr add Map.empty (unionPairs ++ aliasPairs)

src/Canonicalize/Port.hsdeleted−123

@@ -1,123 +0,0 @@

1−module Canonicalize.Port (check) where

2−

3−import qualified Data.Foldable as Foldable

4−

5−import qualified AST.Declaration as D

6−import qualified AST.Expression.General as E

7−import qualified AST.Expression.Canonical as Canonical

8−import qualified AST.Type as T

9−import qualified AST.Variable as Var

10−import qualified Reporting.Annotation as A

11−import qualified Reporting.Error.Canonicalize as Error

12−import qualified Reporting.Region as R

13−import qualified Canonicalize.Result as Result

14−

15−

16−-- CHECK FOR PORT

17−

18−check

19− :: R.Region

20− -> String

21− -> Maybe Canonical.Expr

22− -> T.Canonical

23− -> Result.ResultErr D.CanonicalPort

24−check region name maybeExpr rootType =

25− D.CanonicalPort <$> checkHelp region name maybeExpr rootType rootType

26−

27−

28−checkHelp

29− :: R.Region

30− -> String

31− -> Maybe Canonical.Expr

32− -> T.Canonical

33− -> T.Canonical

34− -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)

35−checkHelp region name maybeExpr rootType tipe =

36− case (maybeExpr, tipe) of

37− (_, T.Aliased _ args t) ->

38− checkHelp region name maybeExpr rootType (T.dealias args t)

39−

40− (Just expr, T.App (T.Type task) [ _x, _a ])

41− | Var.isTask task ->

42− Result.ok (E.Task name expr (T.Normal tipe))

43−

44−

45− (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])

46− | Var.isSignal signal && Var.isTask task ->

47− Result.ok (E.Task name expr (T.Signal tipe arg))

48−

49−

50− (_, T.App (T.Type signal) [arg])

51− | Var.isSignal signal ->

52− case maybeExpr of

53− Nothing ->

54− const (E.In name (T.Signal rootType arg))

55− <$> validForeignType region name True arg arg

56−

57− Just expr ->

58− const (E.Out name expr (T.Signal rootType arg))

59− <$> validForeignType region name False arg arg

60−

61− _ ->

62− case maybeExpr of

63− Nothing ->

64− const (E.In name (T.Normal rootType))

65− <$> validForeignType region name True rootType tipe

66−

67− Just expr ->

68− const (E.Out name expr (T.Normal rootType))

69− <$> validForeignType region name False rootType tipe

70−

71−

72−-- CHECK INBOUND AND OUTBOUND TYPES

73−

74−validForeignType

75− :: R.Region

76− -> String

77− -> Bool

78− -> T.Canonical

79− -> T.Canonical

80− -> Result.ResultErr ()

81−validForeignType region name isInbound rootType tipe =

82− let valid localType =

83− validForeignType region name isInbound rootType localType

84−

85− err problem =

86− Result.err $ A.A region $

87− Error.port name isInbound rootType tipe problem

88− in

89− case tipe of

90− T.Aliased _ args t ->

91− valid (T.dealias args t)

92−

93− T.Type v ->

94− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

95− True -> Result.ok ()

96− False -> err Nothing

97−

98− T.App t [] ->

99− valid t

100−

101− T.App (T.Type v) [t]

102− | Var.isMaybe v -> valid t

103− | Var.isArray v -> valid t

104− | Var.isList v -> valid t

105−

106− T.App (T.Type v) ts

107− | Var.isTuple v ->

108− Foldable.traverse_ valid ts

109−

110− T.App _ _ ->

111− err Nothing

112−

113− T.Var _ ->

114− err (Just "a free type variable")

115−

116− T.Lambda _ _ ->

117− err (Just "a function")

118−

119− T.Record _ (Just _) ->

120− err (Just "an extended record")

121−

122− T.Record fields Nothing ->

123− Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields

src/Canonicalize/Result.hsdeleted−117

@@ -1,117 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Result where

3−

4−import Prelude hiding (foldl)

5−import qualified Control.Applicative as A

6−import qualified Data.Functor as F

7−import qualified Data.Set as Set

8−

9−import qualified AST.Module.Name as ModuleName

10−import qualified AST.Variable as Var

11−import qualified Reporting.Annotation as A

12−import qualified Reporting.Error.Canonicalize as Error

13−

14−

15−type ResultErr a = Result (A.Located Error.Error) a

16−

17−

18−data Result err a =

19− Result (Set.Set ModuleName.Raw) (RawResult err a)

20−

21−

22−data RawResult err a

23− = Ok a

24− | Err [err]

25−

26−

27−-- RESULT HELPERS

28−

29−ok :: a -> Result e a

30−ok value =

31− Result Set.empty (Ok value)

32−

33−

34−err :: e -> Result e a

35−err msg =

36− errors [msg]

37−

38−

39−errors :: [e] -> Result e a

40−errors msgs =

41− Result Set.empty (Err msgs)

42−

43−

44−foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b

45−foldl f acc list =

46− case list of

47− [] ->

48− ok acc

49−

50− x:xs ->

51− f x acc `andThen` (\acc' -> foldl f acc' xs)

52−

53−

54−andThen :: Result e a -> (a -> Result e b) -> Result e b

55−andThen (Result uses rawResult) callback =

56− case rawResult of

57− Err msg ->

58− Result uses (Err msg)

59−

60− Ok value ->

61− let (Result uses' rawResult') = callback value

62− in

63− Result (Set.union uses uses') rawResult'

64−

65−

66−instance F.Functor (Result e) where

67− fmap func (Result uses result) =

68− case result of

69− Ok a ->

70− Result uses (Ok (func a))

71−

72− Err msgs ->

73− Result uses (Err msgs)

74−

75−

76−instance A.Applicative (Result e) where

77− pure value =

78− ok value

79−

80− (<*>) (Result uses resultFunc) (Result uses' resultVal) =

81− Result (Set.union uses uses') $

82− case (resultFunc, resultVal) of

83− (Ok func, Ok val) ->

84− Ok (func val)

85−

86− (Err msgs, Err msgs') ->

87− Err (msgs ++ msgs')

88−

89− (Err msgs, _) ->

90− Err msgs

91−

92− (_, Err msgs) ->

93− Err msgs

94−

95−

96−-- TRACK USES OF IMPORTS

97−

98−addModule :: ModuleName.Raw -> Result e a -> Result e a

99−addModule home (Result uses result) =

100− Result (Set.insert home uses) result

101−

102−

103−var' :: (a -> Var.Canonical) -> a -> Result e a

104−var' toVar value =

105− case toVar value of

106− Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->

107− Result (Set.singleton moduleName) (Ok value)

108−

109− Var.Canonical _ _ ->

110− ok value

111−

112−

113−var :: Var.Canonical -> Result e Var.Canonical

114−var variable =

115− var' id variable

116−

117−

src/Canonicalize/Setup.hs+276−223

@@ -2,12 +2,14 @@

22module Canonicalize.Setup (environment) where

33

44import Control.Arrow (second)

5+import Control.Monad (foldM)

56import qualified Data.Graph as Graph

67import qualified Data.Map as Map

78import qualified Data.Maybe as Maybe

89import qualified Data.Traversable as Trav

910

1011import qualified AST.Declaration as D

12+import qualified AST.Effects as Effects

1113import qualified AST.Expression.Valid as Valid

1214import qualified AST.Module as Module

1315import qualified AST.Module.Name as ModuleName

@@ -19,42 +21,54 @@ import qualified Reporting.Annotation as A

1921import qualified Reporting.Error.Canonicalize as Error

2022import qualified Reporting.Error.Helpers as Error

2123import qualified Reporting.Region as R

24+import qualified Reporting.Result as Result

2225import qualified Canonicalize.Environment as Env

23−import qualified Canonicalize.Result as Result

2426import qualified Canonicalize.Type as Canonicalize

27+import Canonicalize.Variable (Result)

28+

2529

2630

2731environment

2832 :: Map.Map ModuleName.Raw ModuleName.Canonical

2933 -> Module.Interfaces

30− -> Module.ValidModule

31− -> Result.ResultErr Env.Environment

32−environment importDict interfaces (Module.Module name _ _ _ (defaults, imports) decls) =

34+ -> Module.Valid

35+ -> Result Env.Environment

36+environment importDict interfaces (Module.Module name _ info) =

3337 let

38+ (Module.Valid _ _ (defaults, imports) decls effects) =

39+ info

40+

3441 allImports =

3542 imports ++ map (A.A (error "default import not found")) defaults

3643

37− importPatchesResult =

38− concat <$> Trav.traverse (importPatches importDict interfaces) allImports

44+ getImportPatches =

45+ Trav.traverse (importToPatches importDict interfaces) allImports

3946

4047 (typeAliasNodes, declPatches) =

41− declarationsToPatches name decls

48+ declsToPatches name decls

4249

43− patches =

44− (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult

50+ effectPatches =

51+ effectsToPatches name effects

52+

53+ createEnv importPatches =

54+ Env.fromPatches

55+ name

56+ (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))

4557 in

46− (Env.fromPatches name <$> patches)

47− `Result.andThen` addTypeAliases name typeAliasNodes

58+ do env <- createEnv <$> getImportPatches

59+ addTypeAliases name typeAliasNodes env

60+

4861

4962

5063-- PATCHES FOR IMPORTS

5164

52−importPatches

65+

66+importToPatches

5367 :: Map.Map ModuleName.Raw ModuleName.Canonical

5468 -> Module.Interfaces

5569 -> A.Located (ModuleName.Raw, Module.ImportMethod)

56− -> Result.ResultErr [Env.Patch]

57−importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

70+ -> Result [Env.Patch]

71+importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

5872 let

5973 maybeInterface =

6074 do canonicalName <- Map.lookup rawImportName importDict

@@ -63,157 +77,175 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

6377 in

6478 case maybeInterface of

6579 Nothing ->

66− if ModuleName.isNative rawImportName then

67− Result.ok []

68−

69− else

70− allInterfaces

71− |> Map.keys

72− |> map ModuleName._module

73− |> Error.nearbyNames ModuleName.toString rawImportName

74− |> Error.moduleNotFound rawImportName

75− |> A.A region

76− |> Result.err

80+ if ModuleName.isNative rawImportName then

81+ Result.ok []

82+

83+ else

84+ allInterfaces

85+ |> Map.keys

86+ |> map ModuleName._module

87+ |> Error.nearbyNames ModuleName.toString rawImportName

88+ |> Error.moduleNotFound rawImportName

89+ |> Result.throw region

7790

7891 Just (importName, interface) ->

79− let (Module.ImportMethod maybeAlias listing) =

80− method

92+ let

93+ (Module.ImportMethod maybeAlias listing) =

94+ method

95+

96+ (Var.Listing exposedValues open) =

97+ listing

8198

82− (Var.Listing exposedValues open) =

83− listing

99+ qualifier =

100+ maybe (ModuleName.toString rawImportName) id maybeAlias

84101

85− qualifier =

86− maybe (ModuleName.toString rawImportName) id maybeAlias

102+ qualifiedPatches =

103+ interfaceToPatches importName (qualifier ++ ".") interface

87104

88− qualifiedPatches =

89− interfacePatches importName (qualifier ++ ".") interface

105+ unqualifiedPatches =

106+ if open then

107+ Result.ok (interfaceToPatches importName "" interface)

90108

91− unqualifiedPatches =

92− if open

93− then Result.ok (interfacePatches importName "" interface)

94− else concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

95− in

96− (++) qualifiedPatches <$> unqualifiedPatches

109+ else

110+ concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

111+ in

112+ (++) qualifiedPatches <$> unqualifiedPatches

97113

98114

99−interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

100−interfacePatches moduleName prefix interface =

101− let genericPatch mkPatch name value =

102− mkPatch (prefix ++ name) value

115+interfaceToPatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

116+interfaceToPatches moduleName prefix interface =

117+ let

118+ genericPatch mkPatch name value =

119+ mkPatch (prefix ++ name) value

103120

104− patch mkPatch name =

105− genericPatch mkPatch name (Var.fromModule moduleName name)

121+ patch mkPatch name =

122+ genericPatch mkPatch name (Var.fromModule moduleName name)

106123

107− aliasPatch (name, (tvars, tipe)) =

108− genericPatch Env.Alias name

109− (Var.fromModule moduleName name, tvars, tipe)

124+ aliasPatch (name, (tvars, tipe)) =

125+ genericPatch

126+ Env.Alias

127+ name

128+ (Var.fromModule moduleName name, tvars, tipe)

110129

111− patternPatch (name, args) =

112− genericPatch Env.Pattern name

113− (Var.fromModule moduleName name, length args)

130+ patternPatch (name, args) =

131+ genericPatch

132+ Env.Pattern

133+ name

134+ (Var.fromModule moduleName name, length args)

114135

115− ctors =

116− concatMap snd (Map.elems (Module.iAdts interface))

136+ ctors =

137+ concatMap snd (Map.elems (Module.iUnions interface))

138+

139+ ctorNames =

140+ map fst ctors

141+ in

142+ concat

143+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))

144+ , map (patch Env.Value) ctorNames

145+ , map (patch Env.Union) (Map.keys (Module.iUnions interface))

146+ , map aliasPatch (Map.toList (Module.iAliases interface))

147+ , map patternPatch ctors

148+ ]

117149

118− ctorNames =

119− map fst ctors

120− in

121− concat

122− [ map (patch Env.Value) (Map.keys (Module.iTypes interface))

123− , map (patch Env.Value) ctorNames

124− , map (patch Env.Union) (Map.keys (Module.iAdts interface))

125− , map aliasPatch (Map.toList (Module.iAliases interface))

126− , map patternPatch ctors

127− ]

128150

129151

130152-- PATCHES FOR INDIVIDUAL VALUES

131153

154+

132155valueToPatches

133156 :: R.Region

134157 -> ModuleName.Canonical

135158 -> Module.Interface

136159 -> Var.Value

137− -> Result.ResultErr [Env.Patch]

160+ -> Result [Env.Patch]

138161valueToPatches region moduleName interface value =

139− let patch mkPatch x =

140− mkPatch x (Var.fromModule moduleName x)

141−

142− patternPatch (x, numArgs) =

143− Env.Pattern x (Var.fromModule moduleName x, numArgs)

144−

145− notFound getNames x =

146− Module.iExports interface

147− |> getNames

148− |> Error.nearbyNames id x

149− |> Error.valueNotFound (ModuleName._module moduleName) x

150− |> A.A region

151− |> Result.err

162+ let

163+ patch mkPatch x =

164+ mkPatch x (Var.fromModule moduleName x)

165+

166+ patternPatch (x, numArgs) =

167+ Env.Pattern x (Var.fromModule moduleName x, numArgs)

168+

169+ notFound getNames x =

170+ Module.iExports interface

171+ |> getNames

172+ |> Error.nearbyNames id x

173+ |> Error.valueNotFound (ModuleName._module moduleName) x

174+ |> Result.throw region

152175 in

153176 case value of

154177 Var.Value x ->

155− if Map.notMember x (Module.iTypes interface) then

156− notFound Var.getValues x

178+ if Map.notMember x (Module.iTypes interface) then

179+ notFound Var.getValues x

157180

158− else

159− Result.ok [patch Env.Value x]

181+ else

182+ Result.ok [patch Env.Value x]

160183

161184 Var.Alias x ->

162− case Map.lookup x (Module.iAliases interface) of

163− Just (tvars, t) ->

164− let alias =

165− Env.Alias x (Var.fromModule moduleName x, tvars, t)

166− in

167− Result.ok $

168− if Map.member x (Module.iTypes interface)

169− then [alias, patch Env.Value x]

170− else [alias]

171−

172− Nothing ->

173− case Map.lookup x (Module.iAdts interface) of

174− Just (_,_) ->

175− Result.ok [patch Env.Union x]

176−

177− Nothing ->

178− let getNames values =

179− Var.getAliases values

180− ++ map fst (Var.getUnions values)

181− in

182− notFound getNames x

185+ case Map.lookup x (Module.iAliases interface) of

186+ Just (tvars, t) ->

187+ let

188+ alias =

189+ Env.Alias x (Var.fromModule moduleName x, tvars, t)

190+ in

191+ Result.ok $

192+ if Map.member x (Module.iTypes interface) then

193+ [alias, patch Env.Value x]

194+

195+ else

196+ [alias]

197+

198+ Nothing ->

199+ case Map.lookup x (Module.iUnions interface) of

200+ Just (_,_) ->

201+ Result.ok [patch Env.Union x]

202+

203+ Nothing ->

204+ let getNames values =

205+ Var.getAliases values

206+ ++ map fst (Var.getUnions values)

207+ in

208+ notFound getNames x

183209

184210 Var.Union givenName (Var.Listing givenCtorNames open) ->

185− case Map.lookup givenName (Module.iAdts interface) of

186− Nothing ->

187− notFound (map fst . Var.getUnions) givenName

188−

189− Just (_tvars, realCtors) ->

190− patches <$>

191− if open

192− then Result.ok realCtorList

193− else Trav.traverse ctorExists givenCtorNames

194− where

195− realCtorList =

196− map (second length) realCtors

197−

198− realCtorDict =

199− Map.fromList realCtorList

200−

201− ctorExists givenCtorName =

202− case Map.lookup givenCtorName realCtorDict of

203− Just numArgs ->

204− Result.ok (givenCtorName, numArgs)

205− Nothing ->

206− notFound (const (map fst realCtors)) givenCtorName

207−

208− patches ctors =

209− patch Env.Union givenName

210− : map (patch Env.Value . fst) ctors

211− ++ map patternPatch ctors

211+ case Map.lookup givenName (Module.iUnions interface) of

212+ Nothing ->

213+ notFound (map fst . Var.getUnions) givenName

214+

215+ Just (_tvars, realCtors) ->

216+ patches <$>

217+ if open then

218+ Result.ok realCtorList

219+

220+ else

221+ Trav.traverse ctorExists givenCtorNames

222+ where

223+ realCtorList =

224+ map (second length) realCtors

225+

226+ realCtorDict =

227+ Map.fromList realCtorList

228+

229+ ctorExists givenCtorName =

230+ case Map.lookup givenCtorName realCtorDict of

231+ Just numArgs ->

232+ Result.ok (givenCtorName, numArgs)

233+

234+ Nothing ->

235+ notFound (const (map fst realCtors)) givenCtorName

236+

237+ patches ctors =

238+ patch Env.Union givenName

239+ : map (patch Env.Value . fst) ctors

240+ ++ map patternPatch ctors

241+

212242

213243

214244-- PATCHES FOR TYPE ALIASES

215245

216−type Node = ((R.Region, String, [String], Type.Raw), String, [String])

246+

247+type Node =

248+ ( (R.Region, String, [String], Type.Raw), String, [String] )

217249

218250

219251node :: R.Region -> String -> [String] -> Type.Raw -> Node

@@ -221,41 +253,34 @@ node region name tvars alias =

221253 ((region, name, tvars, alias), name, edges alias)

222254 where

223255 edges (A.A _ tipe) =

224− case tipe of

225− Type.RLambda t1 t2 ->

226− edges t1 ++ edges t2

256+ case tipe of

257+ Type.RLambda t1 t2 ->

258+ edges t1 ++ edges t2

227259

228− Type.RVar _ ->

229− []

260+ Type.RVar _ ->

261+ []

230262

231− Type.RType (Var.Raw x) ->

232− [x]

263+ Type.RType (Var.Raw x) ->

264+ [x]

233265

234− Type.RApp t ts ->

235− edges t ++ concatMap edges ts

266+ Type.RApp t ts ->

267+ edges t ++ concatMap edges ts

236268

237− Type.RRecord fs ext ->

238− maybe [] edges ext ++ concatMap (edges . snd) fs

269+ Type.RRecord fs ext ->

270+ maybe [] edges ext ++ concatMap (edges . snd) fs

239271

240272

241−addTypeAliases

242− :: ModuleName.Canonical

243− -> [Node]

244− -> Env.Environment

245− -> Result.ResultErr Env.Environment

273+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment

246274addTypeAliases moduleName typeAliasNodes initialEnv =

247− Result.foldl

248− (addTypeAlias moduleName)

249− initialEnv

250− (Graph.stronglyConnComp typeAliasNodes)

275+ foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)

251276

252277

253278addTypeAlias

254279 :: ModuleName.Canonical

255− -> Graph.SCC (R.Region, String, [String], Type.Raw)

256280 -> Env.Environment

257− -> Result.ResultErr Env.Environment

258−addTypeAlias moduleName scc env =

281+ -> Graph.SCC (R.Region, String, [String], Type.Raw)

282+ -> Result Env.Environment

283+addTypeAlias moduleName env scc =

259284 case scc of

260285 Graph.AcyclicSCC (_, name, tvars, alias) ->

261286 addToEnv <$> Canonicalize.tipe env alias

@@ -267,84 +292,106 @@ addTypeAlias moduleName scc env =

267292 env { Env._aliases = Env.insert name value (Env._aliases env) }

268293

269294 Graph.CyclicSCC [] ->

270− Result.ok env

295+ Result.ok env

271296

272297 Graph.CyclicSCC [(region, name, tvars, alias)] ->

273− Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))

298+ Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))

274299

275300 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->

276− Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))

301+ Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))

302+

277303

278304

279305-- DECLARATIONS TO PATCHES

280306

281−declarationsToPatches

282− :: ModuleName.Canonical

283− -> [D.ValidDecl]

284− -> ([Node], [Env.Patch])

285−declarationsToPatches moduleName decls =

286− let (maybeNodes, patchLists) =

287− unzip (map (declToPatches moduleName) decls)

288− in

289− (Maybe.catMaybes maybeNodes, concat patchLists)

290307

308+{- When canonicalizing, it is important that:

291309

292−-- When canonicalizing, it is important that:

293−-- _adts are fully namespaced (Var.Module ...)

294−-- _patterns are fully namespaced (Var.Module ...)

295−-- _values that are defined as top-level declarations are (Var.TopLevel ...)

296−-- all other _values are local (Var.Local)

297−declToPatches

298− :: ModuleName.Canonical

299− -> D.ValidDecl

300− -> (Maybe Node, [Env.Patch])

301−declToPatches moduleName (A.A (region,_) decl) =

302− let topLevel mkPatch x =

303− mkPatch x (Var.topLevel moduleName x )

310+ _adts are fully namespaced (Var.Module ...)

311+ _patterns are fully namespaced (Var.Module ...)

312+ _values that are defined as top-level declarations are (Var.TopLevel ...)

313+ all other _values are local (Var.Local)

314+

315+-}

316+declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])

317+declsToPatches moduleName (D.Decls defs unions aliases _) =

318+ let

319+

320+ -- HELPERS

321+

322+ topLevelValue x =

323+ Env.Value x (Var.topLevel moduleName x)

324+

325+ patternPatch (name, args) =

326+ Env.Pattern name (Var.fromModule moduleName name, length args)

327+

328+ -- TO PATCHES

329+

330+ defToPatches (A.A _ (Valid.Def pattern _ _)) =

331+ map topLevelValue (P.boundVarList pattern)

304332

305− namespaced mkPatch x =

306− mkPatch x (Var.fromModule moduleName x)

333+ unionToPatches (A.A _ (D.Type name _ ctors)) =

334+ Env.Union name (Var.fromModule moduleName name)

335+ : map topLevelValue (map fst ctors)

336+ ++ map patternPatch ctors

307337

308− patternPatch (name, args) =

309− Env.Pattern name (Var.fromModule moduleName name, length args)

338+ aliasToPatches (A.A _ (D.Type name _ alias)) =

339+ case A.drop alias of

340+ Type.RRecord _ Nothing ->

341+ Just (topLevelValue name)

342+

343+ _ ->

344+ Nothing

345+

346+ -- TO NODES

347+

348+ aliasToNode (A.A (region, _) (D.Type name tvars alias)) =

349+ node region name tvars alias

310350 in

311− case decl of

312− D.Definition (Valid.Definition pattern _ _) ->

313− ( Nothing

314− , map (topLevel Env.Value) (P.boundVarList pattern)

315− )

316−

317− D.Datatype name _ ctors ->

318− let ctorNames = map fst ctors

319− in

320− ( Nothing

321− , namespaced Env.Union name

322− : map (topLevel Env.Value) ctorNames

323− ++ map patternPatch ctors

324− )

325−

326− D.TypeAlias name tvars alias ->

327− ( Just (node region name tvars alias)

328− , case alias of

329− A.A _ (Type.RRecord _ Nothing) ->

330− [topLevel Env.Value name]

331− _ ->

332− []

333− )

334−

335− D.Port port ->

336− ( Nothing

337− , [topLevel Env.Value (D.validPortName port)]

338− )

339−

340− D.Fixity _ _ _ ->

341− ( Nothing

342− , []

343− )

351+ (

352+ map aliasToNode aliases

353+ ,

354+ concat

355+ [ Maybe.mapMaybe aliasToPatches aliases

356+ , concatMap unionToPatches unions

357+ , concatMap defToPatches defs

358+ ]

359+ )

360+

361+

362+-- EFFECTS TO PATCHES

363+

364+

365+effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]

366+effectsToPatches moduleName effects =

367+ case effects of

368+ Effects.None ->

369+ []

370+

371+ Effects.Port ports ->

372+ let

373+ toPatch (A.A _ (Effects.PortRaw name _)) =

374+ Env.Value name (Var.topLevel moduleName name)

375+ in

376+ map toPatch ports

377+

378+ Effects.Manager _ info ->

379+ map (\name -> Env.Value name (Var.topLevel moduleName name)) $

380+ case Effects._managerType info of

381+ Effects.CmdManager _ ->

382+ [ "command" ]

383+

384+ Effects.SubManager _ ->

385+ [ "subscription" ]

386+

387+ Effects.FxManager _ _ ->

388+ [ "command", "subscription" ]

389+

344390

345391

346392-- RESTRICT VISIBLE API OF INTERFACES

347393

394+

348395restrictToPublicApi :: Module.Interface -> Module.Interface

349396restrictToPublicApi interface =

350397 interface

@@ -360,7 +407,7 @@ restrictToPublicApi interface =

360407 (get (Module.iAliases interface))

361408 (Var.getAliases exports)

362409

363− , Module.iAdts =

410+ , Module.iUnions =

364411 Map.fromList

365412 (Maybe.mapMaybe (trimUnions interface) unions)

366413 }

@@ -381,19 +428,25 @@ restrictToPublicApi interface =

381428get :: Map.Map String a -> String -> Maybe (String, a)

382429get dict key =

383430 case Map.lookup key dict of

384− Nothing -> Nothing

385− Just value -> Just (key, value)

431+ Nothing ->

432+ Nothing

433+

434+ Just value ->

435+ Just (key, value)

386436

387437

388438trimUnions

389439 :: Module.Interface

390440 -> (String, Var.Listing String)

391− -> Maybe (String, Module.AdtInfo String)

441+ -> Maybe (String, Module.UnionInfo String)

392442trimUnions interface (name, Var.Listing exportedCtors _) =

393− case Map.lookup name (Module.iAdts interface) of

394− Nothing -> Nothing

443+ case Map.lookup name (Module.iUnions interface) of

444+ Nothing ->

445+ Nothing

446+

395447 Just (tvars, ctors) ->

396− let isExported (ctor, _) =

397− ctor `elem` exportedCtors

448+ let

449+ isExported (ctor, _) =

450+ ctor `elem` exportedCtors

398451 in

399− Just (name, (tvars, filter isExported ctors))

452+ Just (name, (tvars, filter isExported ctors))

src/Canonicalize/Sort.hs+116−100

@@ -7,15 +7,17 @@ import qualified Data.Map as Map

77import qualified Data.Maybe as Maybe

88import qualified Data.Set as Set

99

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

10+import AST.Expression.General (Expr'(..))

1111import qualified AST.Expression.Canonical as Canonical

1212import qualified AST.Pattern as P

1313import qualified AST.Variable as V

1414import qualified Reporting.Annotation as A

1515

1616

17+

1718-- STARTING POINT

1819

20+

1921definitions :: Canonical.Expr -> Canonical.Expr

2022definitions expression =

2123 evalState (reorder expression) Set.empty

@@ -35,138 +37,148 @@ freeIfLocal (V.Canonical home name) =

3537 V.Module _ -> return ()

3638

3739

40+

3841-- REORDER EXPRESSIONS

3942

43+

4044reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr

4145reorder (A.A ann expression) =

42− A.A ann <$>

43− case expression of

44− -- Be careful adding and restricting freeVars

45− Var var ->

46− do freeIfLocal var

47− return expression

46+ A.A ann <$>

47+ case expression of

48+ -- Be careful adding and restricting freeVars

49+ Var var ->

50+ do freeIfLocal var

51+ return expression

4852

49− Lambda pattern body ->

50− uncurry Lambda <$> bindingReorder (pattern,body)

53+ Lambda pattern body ->

54+ uncurry Lambda <$> bindingReorder (pattern,body)

5155

52− Binop op leftExpr rightExpr ->

53− do freeIfLocal op

54− Binop op <$> reorder leftExpr <*> reorder rightExpr

56+ Binop op leftExpr rightExpr ->

57+ do freeIfLocal op

58+ Binop op <$> reorder leftExpr <*> reorder rightExpr

5559

56− Case expr cases ->

57− Case <$> reorder expr <*> mapM bindingReorder cases

60+ Case expr cases ->

61+ Case <$> reorder expr <*> mapM bindingReorder cases

5862

59− Data name exprs ->

60− do free name

61− Data name <$> mapM reorder exprs

63+ Data name exprs ->

64+ do free name

65+ Data name <$> mapM reorder exprs

6266

63− -- Just pipe the reorder though

64− Literal _ ->

65− return expression

67+ -- Just pipe the reorder though

68+ Literal _ ->

69+ return expression

6670

67− Range lowExpr highExpr ->

68− Range <$> reorder lowExpr <*> reorder highExpr

71+ Range lowExpr highExpr ->

72+ Range <$> reorder lowExpr <*> reorder highExpr

6973

70− ExplicitList es ->

71− ExplicitList <$> mapM reorder es

74+ ExplicitList es ->

75+ ExplicitList <$> mapM reorder es

7276

73− App func arg ->

74− App <$> reorder func <*> reorder arg

77+ App func arg ->

78+ App <$> reorder func <*> reorder arg

7579

76− If branches finally ->

77− If

78− <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

79− <*> reorder finally

80+ If branches finally ->

81+ If

82+ <$> mapM (\(cond,branch) -> (,) <$> reorder cond <*> reorder branch) branches

83+ <*> reorder finally

8084

81− Access record field ->

82− Access

83− <$> reorder record

84− <*> return field

85+ Access record field ->

86+ Access

87+ <$> reorder record

88+ <*> return field

8589

86− Update record fields ->

87− Update

88− <$> reorder record

89− <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

90+ Update record fields ->

91+ Update

92+ <$> reorder record

93+ <*> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

9094

91− Record fields ->

92− Record

93− <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

95+ Record fields ->

96+ Record

97+ <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

9498

95− GLShader _ _ _ ->

96− return expression

99+ Cmd _ ->

100+ return expression

97101

98− Port impl ->

99− Port <$>

100− case impl of

101− In _ _ ->

102− return impl

102+ Sub _ ->

103+ return expression

103104

104− Out name expr tipe ->

105− (\e -> Out name e tipe) <$> reorder expr

105+ OutgoingPort _ _ ->

106+ return expression

106107

107− Task name expr tipe ->

108− (\e -> Task name e tipe) <$> reorder expr

108+ IncomingPort _ _ ->

109+ return expression

109110

110− -- Actually do some reordering

111− Let defs body ->

112− do body' <- reorder body

111+ Program _ _ ->

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

113113

114− -- Sort defs into strongly connected components.This

115− -- allows the programmer to write definitions in whatever

116− -- order they please, we can still define things in order

117− -- and generalize polymorphic functions when appropriate.

118− sccs <- Graph.stronglyConnComp <$> buildDefGraph defs

119− let defss = map Graph.flattenSCC sccs

114+ SaveEnv _ _ ->

115+ return expression

120116

121− -- remove let-bound variables from the context

122− forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do

123− bound pattern

124− mapM free (ctors pattern)

117+ GLShader _ _ _ ->

118+ return expression

125119

126− let (A.A _ let') =

127− foldr (\ds bod -> A.A ann (Let ds bod)) body' defss

120+ -- Actually do some reordering

121+ Let defs body ->

122+ do body' <- reorder body

128123

129− return let'

124+ -- Sort defs into strongly connected components.This

125+ -- allows the programmer to write definitions in whatever

126+ -- order they please, we can still define things in order

127+ -- and generalize polymorphic functions when appropriate.

128+ sccs <- Graph.stronglyConnComp <$> buildDefGraph defs

129+ let defss = map Graph.flattenSCC sccs

130130

131+ -- remove let-bound variables from the context

132+ forM_ defs $ \(Canonical.Def _ pattern _ _) -> do

133+ bound pattern

134+ mapM free (ctors pattern)

131135

132−ctors :: P.CanonicalPattern -> [String]

136+ let (A.A _ let') =

137+ foldr (\ds bod -> A.A ann (Let ds bod)) body' defss

138+

139+ return let'

140+

141+

142+ctors :: P.Canonical -> [String]

133143ctors (A.A _ pattern) =

134− case pattern of

135− P.Var _ ->

136− []

144+ case pattern of

145+ P.Var _ ->

146+ []

137147

138− P.Alias _ p ->

139− ctors p

148+ P.Alias _ p ->

149+ ctors p

140150

141− P.Record _ ->

142− []

151+ P.Record _ ->

152+ []

143153

144− P.Anything ->

145− []

154+ P.Anything ->

155+ []

146156

147− P.Literal _ ->

148− []

157+ P.Literal _ ->

158+ []

149159

150− P.Data (V.Canonical home name) ps ->

151− case home of

152− V.Local -> name : rest

153− V.TopLevel _ -> name : rest

154− V.BuiltIn -> rest

155− V.Module _ -> rest

156− where

157− rest = concatMap ctors ps

160+ P.Data (V.Canonical home name) ps ->

161+ case home of

162+ V.Local -> name : rest

163+ V.TopLevel _ -> name : rest

164+ V.BuiltIn -> rest

165+ V.Module _ -> rest

166+ where

167+ rest = concatMap ctors ps

158168

159169

160−bound :: P.CanonicalPattern -> State (Set.Set String) ()

170+bound :: P.Canonical -> State (Set.Set String) ()

161171bound pattern =

162− let boundVars = P.boundVarSet pattern

172+ let

173+ boundVars =

174+ P.boundVarSet pattern

163175 in

164− modify (\freeVars -> Set.difference freeVars boundVars)

176+ modify (\freeVars -> Set.difference freeVars boundVars)

165177

166178

167179bindingReorder

168− :: (P.CanonicalPattern, Canonical.Expr)

169− -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr)

180+ :: (P.Canonical, Canonical.Expr)

181+ -> State (Set.Set String) (P.Canonical, Canonical.Expr)

170182bindingReorder (pattern, expr) =

171183 do expr' <- reorder expr

172184 bound pattern

@@ -174,8 +186,10 @@ bindingReorder (pattern, expr) =

174186 return (pattern, expr')

175187

176188

189+

177190-- BUILD DEPENDENCY GRAPH BETWEEN DEFINITIONS

178191

192+

179193-- This also reorders the all of the sub-expressions in the Def list.

180194buildDefGraph

181195 :: [Canonical.Def]

@@ -186,21 +200,23 @@ buildDefGraph defs =

186200 where

187201 addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])]

188202 addKey =

189− zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

203+ zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

190204

191205 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

192− variableToKey (Canonical.Definition _ pattern _ _, key, _) =

193− [ (var, key) | var <- P.boundVarList pattern ]

206+ variableToKey (Canonical.Def _ pattern _ _, key, _) =

207+ [ (var, key) | var <- P.boundVarList pattern ]

194208

195209 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

196210 variableToKeyMap pdefsDeps =

197− Map.fromList (concatMap variableToKey pdefsDeps)

211+ Map.fromList (concatMap variableToKey pdefsDeps)

198212

199213 realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])]

200214 realDeps pdefsDeps =

201215 map convert pdefsDeps

202216 where

203− varDict = variableToKeyMap pdefsDeps

217+ varDict =

218+ variableToKeyMap pdefsDeps

219+

204220 convert (pdef, key, deps) =

205221 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

206222

@@ -208,7 +224,7 @@ buildDefGraph defs =

208224reorderAndGetDependencies

209225 :: Canonical.Def

210226 -> State (Set.Set String) (Canonical.Def, [String])

211−reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =

227+reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =

212228 do globalFrees <- get

213229 -- work in a fresh environment

214230 put Set.empty

@@ -216,4 +232,4 @@ reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =

216232 localFrees <- get

217233 -- merge with global frees

218234 modify (Set.union globalFrees)

219− return (Canonical.Definition facts pattern expr' mType, Set.toList localFrees)

235+ return (Canonical.Def facts pattern expr' mType, Set.toList localFrees)

src/Canonicalize/Type.hs+38−33

@@ -9,29 +9,30 @@ import qualified AST.Variable as Var

99import qualified Reporting.Annotation as A

1010import qualified Reporting.Error.Canonicalize as Error

1111import qualified Reporting.Region as R

12+import qualified Reporting.Result as Result

1213import qualified Canonicalize.Environment as Env

13−import qualified Canonicalize.Result as Result

1414import qualified Canonicalize.Variable as Canonicalize

15+import Canonicalize.Variable (Result)

1516

1617

17−tipe

18− :: Env.Environment

19− -> T.Raw

20− -> Result.ResultErr T.Canonical

21−tipe env typ@(A.A region typ') =

22− let go = tipe env

23− goSnd (name,t) =

24− (,) name <$> go t

25− in

26− case typ' of

18+tipe :: Env.Environment -> T.Raw -> Result T.Canonical

19+tipe env annType@(A.A _ typ) =

20+ let

21+ go =

22+ tipe env

23+

24+ goSnd (name,t) =

25+ (,) name <$> go t

26+ in

27+ case typ of

2728 T.RVar x ->

2829 Result.ok (T.Var x)

2930

3031 T.RType _ ->

31− canonicalizeApp region env typ []

32+ canonicalizeApp env annType []

3233

3334 T.RApp t ts ->

34− canonicalizeApp region env t ts

35+ canonicalizeApp env t ts

3536

3637 T.RLambda a b ->

3738 T.Lambda <$> go a <*> go b

@@ -40,20 +41,16 @@ tipe env typ@(A.A region typ') =

4041 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext

4142

4243

43−canonicalizeApp

44− :: R.Region

45− -> Env.Environment

46− -> T.Raw

47− -> [T.Raw]

48− -> Result.ResultErr T.Canonical

49−canonicalizeApp region env f args =

50− case f of

51− A.A _ (T.RType (Var.Raw rawName)) ->

52− Canonicalize.tvar region env rawName

53− `Result.andThen` canonicalizeWithTvar

44+canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical

45+canonicalizeApp env annFunc@(A.A region func) args =

46+ case func of

47+ T.RType (Var.Raw rawName) ->

48+ canonicalizeWithTvar =<< Canonicalize.tvar region env rawName

5449

5550 _ ->

56− T.App <$> tipe env f <*> Trav.traverse (tipe env) args

51+ T.App

52+ <$> tipe env annFunc

53+ <*> Trav.traverse (tipe env) args

5754

5855 where

5956 canonicalizeWithTvar tvar =

@@ -65,6 +62,7 @@ canonicalizeApp region env f args =

6562 case args of

6663 [] ->

6764 Result.ok (T.Type name)

65+

6866 _ ->

6967 T.App (T.Type name) <$> Trav.traverse (tipe env) args

7068

@@ -74,14 +72,21 @@ canonicalizeAlias

7472 -> Env.Environment

7573 -> (Var.Canonical, [String], T.Canonical)

7674 -> [T.Raw]

77− -> Result.ResultErr T.Canonical

75+ -> Result T.Canonical

7876canonicalizeAlias region env (name, tvars, dealiasedTipe) types =

79− if typesLen /= tvarsLen

80− then Result.err (A.A region (Error.alias name tvarsLen typesLen))

81− else toAlias <$> Trav.traverse (tipe env) types

82− where

83− typesLen = length types

84− tvarsLen = length tvars

77+ let

78+ typesLen =

79+ length types

80+

81+ tvarsLen =

82+ length tvars

8583

8684 toAlias canonicalTypes =

87− T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

85+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

86+ in

87+ if typesLen /= tvarsLen then

88+ Result.throw region (Error.alias name tvarsLen typesLen)

89+

90+ else

91+ toAlias <$> Trav.traverse (tipe env) types

92+

src/Canonicalize/Variable.hs+74−38

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

11{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Variable where

2+module Canonicalize.Variable (Result, variable, tvar, pvar) where

33

44import qualified Data.Either as Either

55import qualified Data.Map as Map

@@ -9,55 +9,84 @@ import qualified AST.Helpers as Help

99import qualified AST.Module.Name as ModuleName

1010import qualified AST.Type as Type

1111import qualified AST.Variable as Var

12−import qualified Reporting.Annotation as A

12+import qualified Canonicalize.Environment as Env

1313import qualified Reporting.Error.Canonicalize as Error

1414import qualified Reporting.Error.Helpers as Error

1515import qualified Reporting.Region as R

16−import qualified Canonicalize.Environment as Env

17−import qualified Canonicalize.Result as Result

18−import qualified Elm.Package as Pkg

16+import qualified Reporting.Result as Result

17+import qualified Reporting.Warning as Warning

1918import Elm.Utils ((|>))

2019

2120

22−variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical

21+

22+-- RESULT HELPERS

23+

24+

25+type Result a =

26+ Result.Result (Set.Set ModuleName.Raw) Warning.Warning Error.Error a

27+

28+

29+logVarWith :: (a -> Var.Canonical) -> a -> Result a

30+logVarWith toVar value =

31+ case toVar value of

32+ Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->

33+ Result.accumulate (Set.singleton moduleName) value

34+

35+ Var.Canonical _ _ ->

36+ Result.ok value

37+

38+

39+logVar :: Var.Canonical -> Result Var.Canonical

40+logVar var =

41+ logVarWith id var

42+

43+

44+

45+-- FINDERS

46+

47+

48+variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical

2349variable region env var =

2450 case toVarName var of

2551 Right (name, varName) | ModuleName.isNative name ->

26− let

27− moduleName =

28− ModuleName.Canonical Pkg.dummyName name

29− in

30− Result.var (Var.Canonical (Var.Module moduleName) varName)

52+ let

53+ localPkg =

54+ ModuleName._package (Env._home env)

55+

56+ moduleName =

57+ ModuleName.Canonical localPkg name

58+ in

59+ logVar (Var.Canonical (Var.Module moduleName) varName)

3160

3261 _ ->

33− case Set.toList `fmap` Map.lookup var (Env._values env) of

34− Just [v] ->

35− Result.var v

62+ case Set.toList `fmap` Map.lookup var (Env._values env) of

63+ Just [v] ->

64+ logVar v

3665

37− Just vs ->

38− preferLocals region env "variable" vs var

66+ Just vs ->

67+ preferLocals region env "variable" vs var

3968

40− Nothing ->

41− notFound region "variable" (Map.keys (Env._values env)) var

69+ Nothing ->

70+ notFound region "variable" (Map.keys (Env._values env)) var

4271

4372

4473tvar

4574 :: R.Region

4675 -> Env.Environment

4776 -> String

48− -> Result.ResultErr

77+ -> Result

4978 (Either

5079 Var.Canonical

5180 (Var.Canonical, [String], Type.Canonical)

5281 )

5382tvar region env var =

54− case adts ++ aliases of

55− [] -> notFound region "type" (Map.keys (Env._adts env) ++ Map.keys (Env._aliases env)) var

56− [v] -> Result.var' extract v

83+ case unions ++ aliases of

84+ [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var

85+ [v] -> logVarWith extract v

5786 vs -> preferLocals' region env extract "type" vs var

5887 where

59− adts =

60− map Left (maybe [] Set.toList (Map.lookup var (Env._adts env)))

88+ unions =

89+ map Left (maybe [] Set.toList (Map.lookup var (Env._unions env)))

6190

6291 aliases =

6392 map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))

@@ -73,34 +102,37 @@ pvar

73102 -> Env.Environment

74103 -> String

75104 -> Int

76− -> Result.ResultErr Var.Canonical

105+ -> Result Var.Canonical

77106pvar region env var actualArgs =

78107 case Set.toList `fmap` Map.lookup var (Env._patterns env) of

79108 Just [value] ->

80109 foundArgCheck value

81110

82111 Just values ->

83− preferLocals' region env fst "pattern" values var

84− `Result.andThen` foundArgCheck

112+ foundArgCheck =<< preferLocals' region env fst "pattern" values var

85113

86114 Nothing ->

87115 notFound region "pattern" (Map.keys (Env._patterns env)) var

88116 where

89117 foundArgCheck (name, expectedArgs) =

90− if actualArgs == expectedArgs

91− then Result.var name

92− else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))

118+ if actualArgs == expectedArgs then

119+ logVar name

120+

121+ else

122+ Result.throw region (Error.argMismatch name expectedArgs actualArgs)

123+

93124

94125

95126-- FOUND

96127

128+

97129preferLocals

98130 :: R.Region

99131 -> Env.Environment

100132 -> String

101133 -> [Var.Canonical]

102134 -> String

103− -> Result.ResultErr Var.Canonical

135+ -> Result Var.Canonical

104136preferLocals region env =

105137 preferLocals' region env id

106138

@@ -112,28 +144,28 @@ preferLocals'

112144 -> String

113145 -> [a]

114146 -> String

115− -> Result.ResultErr a

147+ -> Result a

116148preferLocals' region env extract kind possibilities var =

117149 case filter (isLocal (Env._home env) . extract) possibilities of

118150 [] ->

119151 ambiguous possibilities

120152

121153 [v] ->

122− Result.var' extract v

154+ logVarWith extract v

123155

124156 --Local vars shadow top-level vars

125157 [v1, v2]

126158 | isTopLevel (extract v1) ->

127− Result.var' extract v2

159+ logVarWith extract v2

128160

129161 | isTopLevel (extract v2) ->

130− Result.var' extract v1

162+ logVarWith extract v1

131163

132164 locals ->

133165 ambiguous locals

134166 where

135167 ambiguous possibleVars =

136− Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))

168+ Result.throw region (Error.variable kind var Error.Ambiguous vars)

137169 where

138170 vars = map (Var.toString . extract) possibleVars

139171

@@ -164,8 +196,10 @@ isTopLevel (Var.Canonical home _) =

164196 False

165197

166198

199+

167200-- NOT FOUND HELPERS

168201

202+

169203type VarName =

170204 Either String (ModuleName.Raw, String)

171205

@@ -194,9 +228,11 @@ isOp name =

194228 Help.isOp (noQualifier name)

195229

196230

231+

197232-- NOT FOUND

198233

199−notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a

234+

235+notFound :: R.Region -> String -> [String] -> String -> Result a

200236notFound region kind possibilities var =

201237 let name =

202238 toVarName var

@@ -212,7 +248,7 @@ notFound region kind possibilities var =

212248 Right (modul, varName) ->

213249 qualifiedProblem modul varName (Either.rights possibleNames)

214250 in

215− Result.err (A.A region (Error.variable kind var problem suggestions))

251+ Result.throw region (Error.variable kind var problem suggestions)

216252

217253

218254exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])

src/Compile.hs+28−17

@@ -2,6 +2,8 @@ module Compile (compile) where

22

33import qualified Data.Map as Map

44

5+import qualified AST.Declaration as D

6+import qualified AST.Expression.Canonical as Can

57import qualified AST.Module as Module

68import qualified AST.Module.Name as ModuleName

79import qualified Canonicalize

@@ -13,25 +15,29 @@ import qualified Optimize

1315import qualified Parse.Helpers as Parse

1416import qualified Parse.Parse as Parse

1517import qualified Reporting.Error as Error

18+import qualified Reporting.Render.Type as RenderType

1619import qualified Reporting.Result as Result

1720import qualified Reporting.Warning as Warning

1821import qualified Type.Inference as TI

1922

2023

24+

25+type Result =

26+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error

27+

28+

2129compile

2230 :: Package.Name

23− -> Bool

2431 -> [ModuleName.Canonical]

2532 -> Module.Interfaces

2633 -> String

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

28−

29−compile packageName isRoot canonicalImports interfaces source =

34+ -> Result Module.Optimized

35+compile packageName canonicalImports interfaces source =

3036 do

3137 -- Parse the source code

3238 validModule <-

33− Result.mapError Error.Syntax $

34− Parse.program packageName isRoot (getOpTable interfaces) source

39+ Result.format Error.Syntax $

40+ Parse.program packageName (getOpTable interfaces) source

3541

3642 -- Canonicalize all variables, pinning down where they came from.

3743 canonicalModule <-

@@ -43,27 +49,32 @@ compile packageName isRoot canonicalImports interfaces source =

4349 TI.infer interfaces canonicalModule

4450

4551 -- One last round of checks

46− Result.mapError Error.Type $

47− Nitpick.topLevelTypes types (Module.body validModule)

52+ canonicalDefs <-

53+ Result.format Error.Type $

54+ Nitpick.topLevelTypes types $

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

4856

4957 tagDict <-

50− Result.mapError Error.Pattern $

58+ Result.format Error.Pattern $

5159 Nitpick.patternMatches interfaces canonicalModule

5260

53− -- Add the real list of types

54− let body =

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

56−

5761 -- Do some basic optimizations

58− let optModule =

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

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

6071

61− return optModule

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

6273

6374

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

6576getOpTable interfaces =

6677 Map.elems interfaces

6778 |> concatMap Module.iFixities

68− |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

79+ |> map (\(D.Infix op assoc lvl) -> ( op, (lvl,assoc) ))

6980 |> Map.fromList

src/Docs/Centralize.hs+56−76

@@ -2,99 +2,79 @@ module Docs.Centralize (centralize) where

22

33import Control.Arrow (second)

44import qualified Data.Map as Map

5+import qualified Data.Maybe as Maybe

56

67import qualified AST.Declaration as D

78import qualified AST.Expression.Canonical as Canonical

8−import qualified AST.Pattern as P

9+import qualified AST.Pattern as Pattern

10+import qualified AST.Type as Type

911import qualified Docs.AST as Docs

1012import qualified Elm.Compiler.Type as Type

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

1214import qualified Reporting.Annotation as A

1315

1416

17+

1518-- CENTRALIZE DOCUMENTATION

1619

17−centralize :: [D.CanonicalDecl] -> String -> Docs.Centralized

18−centralize decls comment =

20+

21+centralize :: D.Canonical -> String -> Docs.Centralized

22+centralize (D.Decls defs unions aliases infixes) comment =

1923 let

20− (Raw aliases types valueInfo fixities) =

21− toRawDocs decls

24+ infixDict =

25+ Map.fromList (map infixToEntry infixes)

26+ in

27+ Docs.Docs

28+ comment

29+ (Map.fromList (map aliasToEntry aliases))

30+ (Map.fromList (map unionToEntry unions))

31+ (Map.fromList (Maybe.mapMaybe (defToEntry infixDict) defs))

32+

33+

34+

35+-- CONVERSION TO DOC ENTRIES

36+

2237

23− values =

24− Map.fromList (map (toValue fixities) (Map.toList valueInfo))

38+defToEntry

39+ :: Map.Map String (String, Int)

40+ -> A.Commented Canonical.Def

41+ -> Maybe (String, A.Located (Docs.Value (Maybe Type.Type)))

42+defToEntry infixDict (A.A (_, maybeComment) (Canonical.Def _ pattern _ maybeType)) =

43+ case pattern of

44+ A.A subregion (Pattern.Var name) ->

45+ let

46+ value =

47+ Docs.Value

48+ maybeComment

49+ (fmap (Extract.toAliasedType . A.drop) maybeType)

50+ (Map.lookup name infixDict)

51+ in

52+ Just (name, A.A subregion value)

53+

54+ _ ->

55+ Nothing

56+

57+

58+unionToEntry :: A.Commented (D.Union Type.Canonical) -> (String, A.Located Docs.Union)

59+unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =

60+ let

61+ ctors' =

62+ map (second (map Extract.toAliasedType)) ctors

2563 in

26− Docs.Docs comment aliases types values

64+ (name, A.A region (Docs.Union maybeComment args ctors'))

2765

2866

29−toValue

30− :: Map.Map String (String, Int)

31− -> ( String, A.Located (Maybe String, Maybe Type.Type) )

32− -> ( String, A.Located (Docs.Value (Maybe Type.Type)) )

33−toValue fixities (name, A.A region (maybeComment, maybeType)) =

67+aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)

68+aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =

3469 ( name

35− , A.A region (Docs.Value maybeComment maybeType (Map.lookup name fixities))

70+ , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))

3671 )

3772

3873

39−-- GATHER INFORMATION

40−

41−data Raw = Raw

42− { rawAliases :: Map.Map String (A.Located Docs.Alias)

43− , rawTypes :: Map.Map String (A.Located Docs.Union)

44− , rawValues :: Map.Map String (A.Located (Maybe String, Maybe Type.Type))

45− , rawFixities :: Map.Map String (String, Int)

46− }

47−

48−

49−toRawDocs :: [D.CanonicalDecl] -> Raw

50−toRawDocs decls =

51− foldr addDeclToDocs (Raw Map.empty Map.empty Map.empty Map.empty) decls

52−

53−

54−addDeclToDocs :: D.CanonicalDecl -> Raw -> Raw

55−addDeclToDocs (A.A (region,maybeComment) decl) docs =

56− case decl of

57− D.Definition (Canonical.Definition _ (A.A subregion (P.Var name)) _ maybeType) ->

58− let

59− info =

60− ( maybeComment

61− , fmap (Extract.toAliasedType . A.drop) maybeType

62− )

63−

64− newValues =

65− Map.insert name (A.A subregion info) (rawValues docs)

66− in

67− docs { rawValues = newValues }

68−

69− D.Definition _ ->

70− docs

71−

72− D.Datatype name args ctors ->

73− let

74− ctors' =

75− map (second (map Extract.toAliasedType)) ctors

76−

77− union =

78− A.A region (Docs.Union maybeComment args ctors')

79− in

80− docs { rawTypes = Map.insert name union (rawTypes docs) }

81−

82− D.TypeAlias name args tipe ->

83− let

84− alias =

85− A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))

86− in

87− docs { rawAliases = Map.insert name alias (rawAliases docs) }

88−

89− D.Port _ ->

90− docs

91−

92− D.Fixity assoc precedence name ->

93− let

94− fixity =

95− (D.assocToString assoc, precedence)

96− in

97− docs

98− { rawFixities =

99− Map.insert name fixity (rawFixities docs)

100− }

74+infixToEntry :: D.Infix -> (String, (String, Int))

75+infixToEntry (D.Infix name assoc precedence) =

76+ let

77+ fixity =

78+ (D.assocToString assoc, precedence)

79+ in

80+ ( name, fixity )

src/Docs/Check.hs+4−2

@@ -1,4 +1,4 @@

1−module Docs.Check (check) where

1+module Docs.Check (Result, check) where

22

33import qualified Data.List as List

44import qualified Data.Map as Map

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

2222import qualified Reporting.Result as R

2323

2424

25−type Result w a = R.Result w Error.Error a

25+

26+type Result w a =

27+ R.Result () w Error.Error a

2628

2729

2830-- CHECK DOCUMENTATION

src/Elm/Compiler.hs+33−35

@@ -11,6 +11,7 @@ module Elm.Compiler

1111

1212import qualified Data.Aeson as Json

1313import qualified Data.Map as Map

14+import qualified Data.Text.Lazy as LazyText

1415import System.IO (Handle)

1516

1617import qualified AST.Module as Module

@@ -25,6 +26,7 @@ import qualified Generate.JavaScript as JS

2526import qualified Parse.Module as Parse

2627import qualified Parse.Parse as Parse

2728import qualified Reporting.Annotation as A

29+import qualified Reporting.Bag as Bag

2830import qualified Reporting.Error as Error

2931import qualified Reporting.Render.Type as RenderType

3032import qualified Reporting.Report as Report

@@ -32,36 +34,35 @@ import qualified Reporting.Result as Result

3234import qualified Reporting.Warning as Warning

3335

3436

37+

3538-- VERSION

3639

40+

3741version :: Package.Version

3842version =

3943 Elm.Compiler.Version.version

4044

4145

46+

4247-- DEPENDENCIES

4348

44−parseDependencies

45− :: String

46− -> Either [Error] (PublicModule.Name, [PublicModule.Name])

49+

50+parseDependencies :: String -> Either [Error] (PublicModule.Raw, [PublicModule.Raw])

4751parseDependencies sourceCode =

4852 let

49− (Result.Result _warnings rawResult) =

53+ (Result.Result _ _ answer) =

5054 Parse.parse sourceCode Parse.header

55+

56+ getDeps (Module.Header _ name _ _ _ imports) =

57+ ( name, map (fst . A.drop) imports )

5158 in

52− case rawResult of

53− Result.Err msgs ->

54− Left $ map (Error . A.map Error.Syntax) msgs

59+ Result.answerToEither (Error . A.map Error.Syntax) getDeps answer

5560

56− Result.Ok (Module.Header name _docs _exports imports) ->

57− Right

58− ( PublicModule.Name name

59− , map (PublicModule.Name . fst . A.drop) imports

60− )

6161

6262

6363-- COMPILATION

6464

65+

6566{-| Compiles Elm source code to JavaScript. -}

6667compile

6768 :: Context

@@ -71,62 +72,55 @@ compile

7172

7273compile context source interfaces =

7374 let

74− (Context packageName isRoot isExposed dependencies) =

75+ (Context packageName isExposed dependencies) =

7576 context

7677

77− (Result.Result (localizer, warnings) rawResult) =

78− do modul <- Compile.compile packageName isRoot dependencies interfaces source

79− docs <- docsGen isExposed modul

78+ (Result.Result oneLocalizer warnings answer) =

79+ do modul <- Compile.compile packageName dependencies interfaces source

80+ docs <- Result.format Error.Docs (docsGen isExposed modul)

8081

8182 let interface = Module.toInterface packageName modul

8283 let javascript = JS.generate modul

8384

8485 return (Result docs interface javascript)

8586 in

86− ( maybe dummyLocalizer Localizer localizer

87− , map Warning warnings

88− , Result.destruct (Left . map Error) Right rawResult

87+ ( Result.oneToValue dummyLocalizer Localizer oneLocalizer

88+ , Bag.toList Warning warnings

89+ , Result.answerToEither Error id answer

8990 )

9091

9192

9293data Context = Context

9394 { _packageName :: Package.Name

94− , _isRoot :: Bool

9595 , _isExposed :: Bool

96− , _dependencies :: [PublicModule.CanonicalName]

96+ , _dependencies :: [PublicModule.Canonical]

9797 }

9898

9999

100100data Result = Result

101101 { _docs :: Maybe Docs.Documentation

102102 , _interface :: PublicModule.Interface

103− , _js :: String

103+ , _js :: LazyText.Text

104104 }

105105

106106

107−docsGen

108− :: Bool

109− -> Module.Optimized

110− -> Result.Result w Error.Error (Maybe Docs.Documentation)

111−docsGen isExposed modul =

107+docsGen :: Bool -> Module.Optimized -> Docs.Result w (Maybe Docs.Documentation)

108+docsGen isExposed (Module.Module name _ info) =

112109 if not isExposed then

113110 Result.ok Nothing

111+

114112 else

115113 let

116− getChecked =

117− Docs.check (Module.exports modul) (Module.docs modul)

118−

119− name =

120− PublicModule.Name (ModuleName._module (Module.name modul))

121−

122114 toDocs checked =

123− Docs.fromCheckedDocs name checked

115+ Just (Docs.fromCheckedDocs (ModuleName._module name) checked)

124116 in

125− (Just . toDocs) `fmap` Result.mapError Error.Docs getChecked

117+ toDocs <$> Docs.check (Module.exports info) (Module.docs info)

118+

126119

127120

128121-- DEALIASER

129122

123+

130124newtype Localizer =

131125 Localizer RenderType.Localizer

132126

@@ -136,8 +130,10 @@ dummyLocalizer =

136130 Localizer Map.empty

137131

138132

133+

139134-- ERRORS

140135

136+

141137newtype Error =

142138 Error (A.Located Error.Error)

143139

@@ -157,8 +153,10 @@ errorToJson (Localizer localizer) location (Error err) =

157153 Error.toJson localizer location err

158154

159155

156+

160157-- WARNINGS

161158

159+

162160newtype Warning =

163161 Warning (A.Located Warning.Warning)

164162

src/Elm/Compiler/Imports.hs+14−1

@@ -17,10 +17,23 @@ defaults =

1717 , ["List"] ==> exposing [Var.Value "::"]

1818 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]

1919 , ["Result"] ==> exposing [Var.Union "Result" Var.openListing]

20− , ["Signal"] ==> exposing [Var.Alias "Signal"]

20+ , ["Platform"] ==> exposing [closedType "Program"]

21+ , ["Platform","Cmd"] ==> named "Cmd" [closedType "Cmd", Var.Value "!"]

22+ , ["Platform","Sub"] ==> named "Sub" [closedType "Sub"]

2123 ]

2224

2325

2426exposing :: [Var.Value] -> Module.ImportMethod

2527exposing vars =

2628 Module.ImportMethod Nothing (Var.listing vars)

29+

30+

31+closedType :: String -> Var.Value

32+closedType name =

33+ Var.Union name Var.closedListing

34+

35+

36+named :: String -> [Var.Value] -> Module.ImportMethod

37+named name vars =

38+ Module.ImportMethod (Just name) (Var.listing vars)

39+

src/Elm/Compiler/Module.hs+52−52

@@ -1,19 +1,17 @@

11module Elm.Compiler.Module

22 ( Interface, Interfaces

3− , Name(Name)

3+ , ModuleName.Raw

44 , nameToPath

55 , nameToString, nameFromString

66 , hyphenate, dehyphenate

7+ , RawForJson(RawForJson), fromJson

78 , defaultImports

8− , interfacePorts

99 , interfaceAliasedTypes

10− , CanonicalName, canonicalName

10+ , ModuleName.Canonical(..), qualifiedVar

1111 )

1212 where

1313

14−import Control.Monad (mzero)

1514import qualified Data.Aeson as Json

16−import Data.Binary

1715import qualified Data.Char as Char

1816import qualified Data.List as List

1917import qualified Data.Map as Map

@@ -25,76 +23,78 @@ import qualified AST.Module.Name as ModuleName

2523import qualified Elm.Compiler.Imports as Imports

2624import qualified Elm.Compiler.Type as Type

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

28−import qualified Elm.Package as Package

26+import qualified Generate.JavaScript.Variable as Gen

27+

2928

3029

3130-- INTERFACES

3231

32+

3333type Interface = Module.Interface

3434

3535

3636type Interfaces = Module.Interfaces

3737

3838

39−interfacePorts :: Interface -> [String]

40−interfacePorts interface =

41− Module.iPorts interface

42−

43−

4439interfaceAliasedTypes :: Interface -> Map.Map String Type.Type

4540interfaceAliasedTypes interface =

4641 Map.map Extract.toAliasedType (Module.iTypes interface)

4742

4843

44+

4945-- NAMES

5046

51−newtype Name = Name ModuleName.Raw

52− deriving (Eq, Ord)

5347

48+newtype RawForJson = RawForJson ModuleName.Raw

5449

55−type CanonicalName = ModuleName.Canonical

5650

51+fromJson :: RawForJson -> ModuleName.Raw

52+fromJson (RawForJson raw) =

53+ raw

5754

58−canonicalName :: Package.Name -> Name -> CanonicalName

59−canonicalName pkgName (Name name) =

60− ModuleName.Canonical pkgName name

6155

56+qualifiedVar :: ModuleName.Canonical -> String -> String

57+qualifiedVar =

58+ Gen.qualified

6259

63−defaultImports :: [Name]

60+

61+defaultImports :: [ModuleName.Raw]

6462defaultImports =

65− map (Name . fst) Imports.defaults

63+ map fst Imports.defaults

64+

65+

6666

67+-- STRING CONVERSIONS for RAW NAMES

6768

68−-- STRING CONVERSIONS for NAMES

6969

70−nameToPath :: Name -> FilePath

71−nameToPath (Name names) =

72− List.foldl1 (</>) names

70+nameToPath :: ModuleName.Raw -> FilePath

71+nameToPath names =

72+ List.foldl1 (</>) names

7373

7474

75−nameToString :: Name -> String

76−nameToString (Name names) =

77− List.intercalate "." names

75+nameToString :: ModuleName.Raw -> String

76+nameToString names =

77+ List.intercalate "." names

7878

7979

80−nameFromString :: String -> Maybe Name

80+nameFromString :: String -> Maybe ModuleName.Raw

8181nameFromString =

82− fromString '.'

82+ fromString '.'

8383

8484

85−hyphenate :: Name -> String

86−hyphenate (Name names) =

87− List.intercalate "-" names

85+hyphenate :: ModuleName.Raw -> String

86+hyphenate names =

87+ List.intercalate "-" names

8888

8989

90−dehyphenate :: String -> Maybe Name

90+dehyphenate :: String -> Maybe ModuleName.Raw

9191dehyphenate =

92− fromString '-'

92+ fromString '-'

9393

9494

95−fromString :: Char -> String -> Maybe Name

95+fromString :: Char -> String -> Maybe ModuleName.Raw

9696fromString sep raw =

97− Name `fmap` mapM isLegit names

97+ mapM isLegit names

9898 where

9999 names =

100100 filter (/= [sep]) (List.groupBy (\a b -> a /= sep && b /= sep) raw)

@@ -111,28 +111,28 @@ fromString sep raw =

111111 Char.isAlphaNum char || char `elem` "_'"

112112

113113

114−-- JSON for NAME

115114

116−instance Json.ToJSON Name where

117− toJSON name =

118− Json.toJSON (nameToString name)

115+-- JSON for NAME

119116

120117

121−instance Json.FromJSON Name where

122− parseJSON (Json.String text) =

123− let rawName = Text.unpack text in

124− case nameFromString rawName of

125− Nothing -> fail (rawName ++ " is not a valid module name")

126− Just name -> return name

118+instance Json.ToJSON RawForJson where

119+ toJSON (RawForJson name) =

120+ Json.toJSON (nameToString name)

127121

128− parseJSON _ = mzero

129122

123+instance Json.FromJSON RawForJson where

124+ parseJSON (Json.String text) =

125+ let

126+ rawString =

127+ Text.unpack text

128+ in

129+ case nameFromString rawString of

130+ Nothing ->

131+ fail (rawString ++ " is not a valid module name")

130132

131−-- BINARY for NAME

133+ Just name ->

134+ return (RawForJson name)

132135

133−instance Binary Name where

134− get =

135− fmap Name get

136+ parseJSON _ =

137+ fail "expecting the module name to be a string"

136138

137− put (Name names) =

138− put names

src/Elm/Compiler/Type/Extract.hs+2−1

@@ -40,5 +40,6 @@ toType useAliases astType =

4040 Type.Aliased name args t ->

4141 if useAliases then

4242 T.App (T.Type (Var.toString name)) (map (go . snd) args)

43+

4344 else

44− go (Type.dealias args t)

45+ go (Type.dealias args t)

src/Elm/Docs.hs+30−9

@@ -18,8 +18,12 @@ import qualified Elm.Package as Pkg

1818import qualified Reporting.Annotation as A

1919

2020

21+

22+-- DATA STRUCTURES

23+

24+

2125data Documentation = Documentation

22− { moduleName :: Module.Name

26+ { moduleName :: Module.Raw

2327 , comment :: String

2428 , aliases :: [Alias]

2529 , types :: [Union]

@@ -55,9 +59,11 @@ data Value = Value

5559data Version = NonCanonicalTypes | Version String

5660

5761

62+

5863-- FROM CHECKED DOCS

5964

60−fromCheckedDocs :: Module.Name -> Docs.Checked -> Documentation

65+

66+fromCheckedDocs :: Module.Raw -> Docs.Checked -> Documentation

6167fromCheckedDocs name (Docs.Docs comment aliases unions values) =

6268 let

6369 unwrap cmnt =

@@ -72,15 +78,19 @@ fromCheckedDocs name (Docs.Docs comment aliases unions values) =

7278 toValue (name, (A.A _ (Docs.Value cmnt tipe fix))) =

7379 Value name (unwrap cmnt) tipe fix

7480 in

75− Documentation name comment

76− (map toAlias (Map.toList aliases))

77− (map toUnion (Map.toList unions))

78− (map toValue (Map.toList values))

79− (Version $ (Pkg.versionToString Version.version))

81+ Documentation

82+ name

83+ comment

84+ (map toAlias (Map.toList aliases))

85+ (map toUnion (Map.toList unions))

86+ (map toValue (Map.toList values))

87+ (Version $ (Pkg.versionToString Version.version))

88+

8089

8190

8291-- PRETTY JSON

8392

93+

8494prettyJson :: (Json.ToJSON a) => a -> BS.ByteString

8595prettyJson value =

8696 Json.encodePretty' config value

@@ -99,12 +109,14 @@ config =

99109 ]

100110

101111

112+

102113-- JSON for DOCUMENTATION

103114

115+

104116instance Json.ToJSON Documentation where

105117 toJSON (Documentation name comment aliases types values version) =

106118 Json.object

107− [ "name" .= name

119+ [ "name" .= Module.RawForJson name

108120 , "comment" .= comment

109121 , "aliases" .= aliases

110122 , "types" .= types

@@ -116,7 +128,7 @@ instance Json.ToJSON Documentation where

116128instance Json.FromJSON Documentation where

117129 parseJSON (Json.Object obj) =

118130 Documentation

119− <$> obj .: "name"

131+ <$> fmap Module.fromJson (obj .: "name")

120132 <*> obj .: "comment"

121133 <*> obj .: "aliases"

122134 <*> obj .: "types"

@@ -127,8 +139,11 @@ instance Json.FromJSON Documentation where

127139 fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value)

128140

129141

142+

143+

130144-- JSON for VERSION

131145

146+

132147instance Json.ToJSON Version where

133148 toJSON version =

134149 case version of

@@ -149,8 +164,10 @@ instance Json.FromJSON Version where

149164 fail $ "Cannot decode version of documentation from: " ++ BS.unpack (Json.encode value)

150165

151166

167+

152168-- JSON for ALIAS

153169

170+

154171instance Json.ToJSON Alias where

155172 toJSON (Alias name comment args tipe) =

156173 Json.object

@@ -172,8 +189,10 @@ instance Json.FromJSON Alias where

172189 fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value)

173190

174191

192+

175193-- JSON for UNION

176194

195+

177196instance Json.ToJSON Union where

178197 toJSON (Union name comment args cases) =

179198 Json.object

@@ -195,8 +214,10 @@ instance Json.FromJSON Union where

195214 fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value)

196215

197216

217+

198218-- JSON for VALUE

199219

220+

200221instance Json.ToJSON Value where

201222 toJSON (Value name comment tipe assocPrec) =

202223 Json.object (fields ++ possibleFields)

src/Elm/Package.hs+12−2

@@ -26,11 +26,21 @@ dummyName =

2626 Name "user" "project"

2727

2828

29−coreName :: Name

30−coreName =

29+core :: Name

30+core =

3131 Name "elm-lang" "core"

3232

3333

34+virtualDom :: Name

35+virtualDom =

36+ Name "elm-lang" "virtual-dom"

37+

38+

39+html :: Name

40+html =

41+ Name "elm-lang" "html"

42+

43+

3444toString :: Name -> String

3545toString name =

3646 user name ++ "/" ++ project name

src/Elm/Utils.hs+2−3

@@ -18,7 +18,6 @@ import System.FilePath ((</>))

1818import System.IO.Error (tryIOError)

1919import System.Process (readProcessWithExitCode)

2020

21−import qualified AST.Expression.Source as Source

2221import qualified AST.Pattern as Pattern

2322import qualified Elm.Compiler.Version as Version

2423import qualified Elm.Package as Pkg

@@ -154,8 +153,8 @@ errorNotFound name =

154153

155154isDeclaration :: String -> Maybe String

156155isDeclaration string =

157− case Parse.iParse Parse.definition string of

158− Right (A.A _ (Source.Definition pattern _)) ->

156+ case Parse.iParse (Parse.definition (,)) string of

157+ Right (A.A _ (pattern, _)) ->

159158 Just (List.intercalate "$" (Pattern.boundVarList pattern))

160159

161160 _ ->

src/Generate/JavaScript.hs+61−132

@@ -1,162 +1,91 @@

11module Generate.JavaScript (generate) where

22

3−import Control.Monad.State as State

4−import qualified Data.List as List

5−import Language.ECMAScript3.PrettyPrint as ES

6−import Language.ECMAScript3.Syntax

7−import qualified Text.PrettyPrint.Leijen as PP

8−

9−import qualified AST.Expression.Optimized as Optimized

10−import qualified AST.Helpers as Help

3+import qualified Control.Monad.State as State

4+import qualified Data.Text.Lazy as LazyText

5+import qualified Language.ECMAScript3.Syntax as JS

6+

7+import qualified AST.Effects as Effects

118import qualified AST.Module as Module

129import qualified AST.Module.Name as ModuleName

13−import qualified AST.Variable as Variable

10+import qualified Elm.Package as Pkg

11+import qualified Generate.JavaScript.Builder as Builder

1412import qualified Generate.JavaScript.Expression as JS

15−import Generate.JavaScript.Helpers (call, function, localRuntime, obj, prop, ref, varDecl)

13+import qualified Generate.JavaScript.Helpers as JS

1614import qualified Generate.JavaScript.Variable as Var

1715

1816

19−generate :: Module.Optimized -> String

20−generate module_ =

21− let

22− (ModuleName.Canonical _ name) =

23− Module.name module_

24−

25− body =

26− concat

27− [ useStrict

28− , checkForCachedVersion name

29− , imports (Module.imports module_)

30− , definitions (Module.program (Module.body module_))

31− , exports name (Module.exports module_)

32− ]

33−

34− make =

35− "Elm" : name ++ ["make"]

36−

37− javascript =

38− buildIntermediateObjects make

39− ++

40− [ assign make (function [localRuntime] body)

41− ]

42− in

43− PP.displayS (PP.renderPretty 1 160 (ES.prettyPrint javascript)) ""

44−

45−

46−

47−-- INTRO

48−

4917

50−useStrict :: [Statement ()]

51−useStrict =

52− [ ExprStmt () (StringLit () "use strict")

53− ]

18+-- GENERATE JAVASCRIPT

5419

5520

56−checkForCachedVersion :: ModuleName.Raw -> [Statement ()]

57−checkForCachedVersion name =

21+generate :: Module.Optimized -> LazyText.Text

22+generate (Module.Module moduleName _ info) =

5823 let

59− values =

60− localRuntime : name ++ ["values"]

61−

62− valuesObject =

63− obj values

64− in

65− buildIntermediateObjects values

66− ++

67− [ IfSingleStmt () valuesObject (ReturnStmt () (Just valuesObject))

68− ]

69−

70−

71−buildIntermediateObjects :: [String] -> [Statement ()]

72−buildIntermediateObjects path =

73− let

74− create name =

75− assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

76−

77− paths =

78− drop 2 (init (List.inits path))

79− in

80− map create paths

81−

24+ genBody =

25+ do defsList <- mapM JS.generateDef (Module.program info)

26+ let managerStmts = generateEffectManager moduleName (Module.effects info)

27+ return (concat (defsList ++ [managerStmts]))

8228

83−assign :: [String] -> Expression () -> Statement ()

84−assign path expr =

85− case path of

86− [x] ->

87− VarDeclStmt () [ varDecl x expr ]

88−

89− _ ->

90− ExprStmt () $

91− AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

92−

93−

94−

95−-- IMPORTS

96−

97−

98−imports :: [ModuleName.Raw] -> [Statement ()]

99−imports rawImports =

100− let

101− utils =

102− varDecl "_U" (call (obj ["Elm", "Native", "Utils", "make"]) [ref localRuntime])

103− in

104− [ VarDeclStmt () (utils : map jsImport rawImports) ]

105−

106−

107−jsImport :: ModuleName.Raw -> VarDecl ()

108−jsImport name =

109− let

110− make =

111− obj ("Elm" : name ++ ["make"])

29+ body =

30+ State.evalState genBody 0

11231 in

113− varDecl (Var.modulePrefix name) (call make [ref localRuntime])

32+ Builder.stmtsToText body

11433

11534

11635

117−-- DEFINITIONS

36+-- GENERATE EFFECT MANAGER

11837

11938

120−definitions :: [Optimized.Def] -> [Statement ()]

121−definitions defs =

122− let

123− setup =

124− Var.define "_op" (ObjectLit () [])

125− in

126− setup : State.evalState (mapM JS.generateDef defs) 0

39+generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Statement ()]

40+generateEffectManager moduleName effects =

41+ case effects of

42+ Effects.None ->

43+ []

12744

45+ Effects.Port _ ->

46+ []

12847

48+ Effects.Manager pkgName (Effects.Info _ _ _ _ managerType) ->

49+ let

50+ managers =

51+ Var.native (ModuleName.inCore ["Native","Platform"]) "effectManagers"

12952

130−-- EXPORTS

53+ managerName =

54+ JS.StringLit () (ModuleName.canonicalToString moduleName)

13155

56+ entry name =

57+ ( JS.PropId () (JS.Id () name)

58+ , JS.ref (Var.qualified moduleName name)

59+ )

13260

133−exports :: ModuleName.Raw -> [Variable.Value] -> [Statement ()]

134−exports name exportedValues =

135− let

136− exportedFields =

137− map toField ("_op" : concatMap extract exportedValues)

61+ managerEntries =

62+ [ "pkg" ==> Pkg.toString pkgName

63+ , entry "init"

64+ , entry "onEffects"

65+ , entry "onSelfMsg"

66+ ]

13867

139− toField x =

140− (prop x, ref x)

68+ otherEntries =

69+ case managerType of

70+ Effects.CmdManager _ ->

71+ [ "tag" ==> "cmd", entry "cmdMap" ]

14172

142− extract value =

143− case value of

144− Variable.Alias _ ->

145− []

73+ Effects.SubManager _ ->

74+ [ "tag" ==> "sub", entry "subMap" ]

14675

147− Variable.Value x ->

148− if Help.isOp x then

149− []

76+ Effects.FxManager _ _ ->

77+ [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]

15078

151− else

152− [Var.safe x]

79+ addManager =

80+ JS.AssignExpr () JS.OpAssign

81+ (JS.LBracket () managers managerName)

82+ (JS.ObjectLit () (managerEntries ++ otherEntries))

83+ in

84+ [ JS.ExprStmt () addManager ]

15385

154− Variable.Union _ (Variable.Listing ctors _) ->

155− map Var.safe ctors

15686

157− values =

158− LDot () (obj (localRuntime : name)) "values"

159− in

160− [ ReturnStmt () $ Just $

161− AssignExpr () OpAssign values (ObjectLit () exportedFields)

162− ]

87+(==>) :: String -> String -> ( JS.Prop (), JS.Expression () )

88+(==>) key value =

89+ ( JS.PropId () (JS.Id () key)

90+ , JS.StringLit () value

91+ )

src/Generate/JavaScript/Builder.hsnew file+528

@@ -0,0 +1,528 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Generate.JavaScript.Builder (stmtsToText) where

4+

5+import qualified Data.List as List

6+import Data.Monoid ((<>))

7+import qualified Data.Text.Lazy as LazyText

8+import Data.Text.Lazy.Builder

9+import Data.Text.Lazy.Builder.Int (decimal)

10+import Data.Text.Lazy.Builder.RealFloat (realFloat)

11+import Language.ECMAScript3.Syntax

12+import Prelude hiding (lines)

13+

14+

15+

16+-- CONVERT TO LAZY TEXT

17+

18+

19+stmtsToText :: [Statement a] -> LazyText.Text

20+stmtsToText stmts =

21+ toLazyText (fromStmtBlock "" stmts)

22+

23+

24+

25+-- HELPERS

26+

27+

28+deeper :: Builder -> Builder

29+deeper indent =

30+ "\t" <> indent

31+

32+

33+commaSep :: [Builder] -> Builder

34+commaSep builders =

35+ mconcat (List.intersperse ", " builders)

36+

37+

38+commaNewlineSep :: Builder -> [Builder] -> Builder

39+commaNewlineSep indent builders =

40+ mconcat (List.intersperse (",\n" <> deeper indent) builders)

41+

42+

43+

44+-- STATEMENTS

45+

46+

47+fromStmtBlock :: Builder -> [Statement a] -> Builder

48+fromStmtBlock indent stmts =

49+ mconcat (map (fromStmt indent) stmts)

50+

51+

52+fromStmt :: Builder -> Statement a -> Builder

53+fromStmt indent statement =

54+ case statement of

55+ BlockStmt _ stmts ->

56+ fromStmtBlock indent stmts

57+

58+ EmptyStmt _ ->

59+ mempty

60+

61+ ExprStmt _ expr ->

62+ indent <> snd (fromExpr indent Whatever expr) <> ";\n"

63+

64+ IfStmt _ condition thenStmt elseStmt ->

65+ mconcat

66+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

67+ , fromStmt (deeper indent) thenStmt

68+ , indent, "} else {\n"

69+ , fromStmt (deeper indent) elseStmt

70+ , indent, "}\n"

71+ ]

72+

73+ IfSingleStmt _ condition thenStmt ->

74+ mconcat

75+ [ indent, "if (", snd (fromExpr indent Whatever condition), ") {\n"

76+ , fromStmt (deeper indent) thenStmt

77+ , indent, "}\n"

78+ ]

79+

80+ SwitchStmt _ expr clauses ->

81+ mconcat

82+ [ indent, "switch (", snd (fromExpr indent Whatever expr), ") {\n"

83+ , mconcat (map (fromClause (deeper indent)) clauses)

84+ , indent, "}\n"

85+ ]

86+

87+ WhileStmt _ expr stmt ->

88+ mconcat

89+ [ indent, "while (", snd (fromExpr indent Whatever expr), ") {\n"

90+ , fromStmt (deeper indent) stmt

91+ , indent, "}\n"

92+ ]

93+

94+ DoWhileStmt _ stmt expr ->

95+ mconcat

96+ [ indent, "do {\n"

97+ , fromStmt (deeper indent) stmt

98+ , indent, "} while(", snd (fromExpr indent Whatever expr), ");\n"

99+ ]

100+

101+ BreakStmt _ Nothing ->

102+ indent <> "break;\n"

103+

104+ BreakStmt _ (Just label) ->

105+ indent <> "break " <> fromId label <> ";\n"

106+

107+ ContinueStmt _ Nothing ->

108+ indent <> "continue;\n"

109+

110+ ContinueStmt _ (Just label) ->

111+ indent <> "continue " <> fromId label <> ";\n"

112+

113+ LabelledStmt _ label stmt ->

114+ mconcat

115+ [ indent, fromId label, ":\n"

116+ , fromStmt indent stmt

117+ ]

118+

119+ ForInStmt _ _ _ _ ->

120+ error "TODO"

121+

122+ ForStmt _ _ _ _ _ ->

123+ error "TODO"

124+

125+ TryStmt _ _ _ _ ->

126+ error "TODO"

127+

128+ ThrowStmt _ expr ->

129+ indent <> "throw " <> snd (fromExpr indent Whatever expr) <> ";\n"

130+

131+ ReturnStmt _ Nothing ->

132+ indent <> "return;\n"

133+

134+ ReturnStmt _ (Just expr) ->

135+ indent <> "return " <> snd (fromExpr indent Whatever expr) <> ";\n"

136+

137+ WithStmt _ _ _ ->

138+ error "TODO"

139+

140+ VarDeclStmt _ [] ->

141+ mempty

142+

143+ VarDeclStmt _ decls ->

144+ indent <> "var " <> commaNewlineSep indent (map (fromVarDecl indent) decls) <> ";\n"

145+

146+ FunctionStmt _ name args stmts ->

147+ indent <> "function " <> fromId name <> "(" <> commaSep (map fromId args) <> ") {\n"

148+ <>

149+ fromStmtBlock (deeper indent) stmts

150+ <>

151+ indent <> "}\n"

152+

153+

154+

155+-- SWITCH CLAUSES

156+

157+

158+fromClause :: Builder -> CaseClause a -> Builder

159+fromClause indent clause =

160+ case clause of

161+ CaseClause _ expr stmts ->

162+ indent <> "case " <> snd (fromExpr indent Whatever expr) <> ":\n"

163+ <> fromStmtBlock (deeper indent) stmts

164+

165+ CaseDefault _ stmts ->

166+ indent <> "default:\n"

167+ <> fromStmtBlock (deeper indent) stmts

168+

169+

170+

171+-- ID

172+

173+

174+fromId :: Id a -> Builder

175+fromId (Id _ name) =

176+ fromString name

177+

178+

179+

180+-- VAR DECLS

181+

182+

183+fromVarDecl :: Builder -> VarDecl a -> Builder

184+fromVarDecl indent (VarDecl _ (Id _ name) maybeExpr) =

185+ case maybeExpr of

186+ Nothing ->

187+ fromString name

188+

189+ Just expr ->

190+ fromString name <> " = " <> snd (fromExpr indent Whatever expr)

191+

192+

193+

194+-- EXPRESSIONS

195+

196+

197+data Lines = One | Many deriving (Eq)

198+

199+

200+merge :: Lines -> Lines -> Lines

201+merge a b =

202+ if a == Many || b == Many then Many else One

203+

204+

205+linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])

206+linesMap func xs =

207+ let

208+ pairs =

209+ map func xs

210+ in

211+ ( any ((==) Many . fst) pairs

212+ , map snd pairs

213+ )

214+

215+

216+data Grouping = Atomic | Whatever

217+

218+

219+parensFor :: Grouping -> Builder -> Builder

220+parensFor grouping builder =

221+ case grouping of

222+ Atomic ->

223+ "(" <> builder <> ")"

224+

225+ Whatever ->

226+ builder

227+

228+

229+fromExpr :: Builder -> Grouping -> Expression a -> (Lines, Builder)

230+fromExpr indent grouping expression =

231+ case expression of

232+ StringLit _ string ->

233+ (One, quoted string)

234+

235+ RegexpLit _ _ _ _ ->

236+ error "TODO"

237+

238+ NumLit _ n ->

239+ (One, realFloat n)

240+

241+ IntLit _ n ->

242+ (One, decimal n)

243+

244+ BoolLit _ True ->

245+ (One, "true")

246+

247+ BoolLit _ False ->

248+ (One, "false")

249+

250+ NullLit _ ->

251+ (One, "null")

252+

253+ ArrayLit _ exprs ->

254+ (,) Many $

255+ let

256+ (anyMany, builders) =

257+ linesMap (fromExpr indent Whatever) exprs

258+ in

259+ if anyMany then

260+ "[\n"

261+ <> deeper indent

262+ <> commaNewlineSep indent builders

263+ <> "\n" <> indent <> "]"

264+

265+ else

266+ "[" <> commaSep builders <> "]"

267+

268+ ObjectLit _ fields ->

269+ (,) Many $

270+ let

271+ deeperIndent =

272+ deeper indent

273+

274+ (anyMany, builders) =

275+ linesMap (fromField deeperIndent) fields

276+ in

277+ if anyMany then

278+ "{\n"

279+ <> deeperIndent

280+ <> commaNewlineSep indent builders

281+ <> "\n" <> indent <> "}"

282+

283+ else

284+ "{" <> commaSep builders <> "}"

285+

286+ ThisRef _ ->

287+ (One, "this")

288+

289+ VarRef _ name ->

290+ (One, fromId name)

291+

292+ DotRef _ expr (Id _ name) ->

293+ makeDot indent expr name

294+

295+ BracketRef _ expr bracketedExpr ->

296+ makeBracketed indent expr bracketedExpr

297+

298+ NewExpr _ _ _ ->

299+ error "TODO"

300+

301+ PrefixExpr _ op expr ->

302+ let

303+ (lines, builder) =

304+ fromExpr indent Atomic expr

305+ in

306+ ( lines

307+ , parensFor grouping (fromPrefix op <> builder)

308+ )

309+

310+ UnaryAssignExpr _ _ _ ->

311+ error "TODO"

312+

313+ InfixExpr _ op leftExpr rightExpr ->

314+ let

315+ (leftLines, left) =

316+ fromExpr indent Atomic leftExpr

317+

318+ (rightLines, right) =

319+ fromExpr indent Atomic rightExpr

320+ in

321+ ( merge leftLines rightLines

322+ , parensFor grouping (left <> fromInfix op <> right)

323+ )

324+

325+ CondExpr _ condExpr thenExpr elseExpr ->

326+ let

327+ condB = snd (fromExpr indent Atomic condExpr)

328+ thenB = snd (fromExpr indent Atomic thenExpr)

329+ elseB = snd (fromExpr indent Atomic elseExpr)

330+ in

331+ ( Many

332+ , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)

333+ )

334+

335+ AssignExpr _ op lValue expr ->

336+ let

337+ (leftLines, left) =

338+ fromLValue indent lValue

339+

340+ (rightLines, right) =

341+ fromExpr indent Whatever expr

342+ in

343+ ( merge leftLines rightLines

344+ , parensFor grouping (left <> fromAssign op <> right)

345+ )

346+

347+ ListExpr _ _ ->

348+ error "TODO"

349+

350+ CallExpr _ function args ->

351+ (,) Many $

352+ let

353+ deeperIndent =

354+ deeper indent

355+

356+ funcB =

357+ snd (fromExpr indent Atomic function)

358+

359+ (anyMany, argsB) =

360+ linesMap (fromExpr deeperIndent Whatever) args

361+ in

362+ if anyMany then

363+ funcB <> "(\n" <> deeperIndent <> commaNewlineSep indent argsB <> ")"

364+

365+ else

366+ funcB <> "(" <> commaSep argsB <> ")"

367+

368+ FuncExpr _ maybeName args stmts ->

369+ (,) Many $

370+ "function " <> maybe mempty fromId maybeName <> "(" <> commaSep (map fromId args) <> ") {\n"

371+ <>

372+ fromStmtBlock (deeper indent) stmts

373+ <>

374+ indent <> "}"

375+

376+

377+

378+-- FIELDS

379+

380+

381+fromField :: Builder -> (Prop a, Expression a) -> (Lines, Builder)

382+fromField indent (prop, expr) =

383+ let

384+ (lines, builder) =

385+ fromExpr indent Whatever expr

386+ in

387+ ( lines

388+ , fromProp prop <> ": " <> builder

389+ )

390+

391+

392+fromProp :: Prop a -> Builder

393+fromProp prop =

394+ case prop of

395+ PropId _ name ->

396+ fromId name

397+

398+ PropString _ string ->

399+ quoted string

400+

401+ PropNum _ n ->

402+ decimal n

403+

404+

405+

406+-- STRINGS

407+

408+

409+quoted :: String -> Builder

410+quoted string =

411+ fromString ('\'' : foldr escapeCons "'" string)

412+

413+

414+-- https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Grammar_and_types#String_literals

415+escapeCons :: Char -> String -> String

416+escapeCons char rest =

417+ case char of

418+ '\b' -> '\\' : 'b' : rest

419+ '\f' -> '\\' : 'f' : rest

420+ '\n' -> '\\' : 'n' : rest

421+ '\r' -> '\\' : 'r' : rest

422+ '\t' -> '\\' : 't' : rest

423+ '\v' -> '\\' : 'v' : rest

424+ '\"' -> '\\' : '"' : rest

425+ '\'' -> '\\' : '\'' : rest

426+ '\\' -> '\\' : '\\' : rest

427+ _ -> char : rest

428+

429+

430+

431+-- VALUES

432+

433+

434+fromLValue :: Builder -> LValue a -> (Lines, Builder)

435+fromLValue indent lValue =

436+ case lValue of

437+ LVar _ name ->

438+ (One, fromString name)

439+

440+ LDot _ expr field ->

441+ makeDot indent expr field

442+

443+ LBracket _ expr bracketedExpr ->

444+ makeBracketed indent expr bracketedExpr

445+

446+

447+makeDot :: Builder -> Expression a -> String -> (Lines, Builder)

448+makeDot indent expr field =

449+ let

450+ (lines, builder) =

451+ fromExpr indent Atomic expr

452+ in

453+ (lines, builder <> "." <> fromString field)

454+

455+

456+makeBracketed :: Builder -> Expression a -> Expression a -> (Lines, Builder)

457+makeBracketed indent expr bracketedExpr =

458+ let

459+ (lines, builder) =

460+ fromExpr indent Atomic expr

461+

462+ (bracketedLines, bracketedBuilder) =

463+ fromExpr indent Whatever bracketedExpr

464+ in

465+ ( merge lines bracketedLines

466+ , builder <> "[" <> bracketedBuilder <> "]"

467+ )

468+

469+

470+

471+-- OPERATORS

472+

473+

474+fromPrefix :: PrefixOp -> Builder

475+fromPrefix op =

476+ case op of

477+ PrefixLNot -> "!"

478+ PrefixBNot -> "~"

479+ PrefixPlus -> "+"

480+ PrefixMinus -> "-"

481+ PrefixTypeof -> "typeof "

482+ PrefixVoid -> "void "

483+ PrefixDelete -> "delete "

484+

485+

486+fromAssign :: AssignOp -> Builder

487+fromAssign op =

488+ case op of

489+ OpAssign -> " = "

490+ OpAssignAdd -> " += "

491+ OpAssignSub -> " -= "

492+ OpAssignMul -> " *= "

493+ OpAssignDiv -> " /= "

494+ OpAssignMod -> " %= "

495+ OpAssignLShift -> " <<= "

496+ OpAssignSpRShift -> " >>= "

497+ OpAssignZfRShift -> " >>>= "

498+ OpAssignBAnd -> " &= "

499+ OpAssignBXor -> " ^= "

500+ OpAssignBOr -> " |= "

501+

502+

503+fromInfix :: InfixOp -> Builder

504+fromInfix op =

505+ case op of

506+ OpLT -> " < "

507+ OpLEq -> " <= "

508+ OpGT -> " > "

509+ OpGEq -> " >= "

510+ OpIn -> " in "

511+ OpInstanceof -> " instanceof "

512+ OpEq -> " == "

513+ OpNEq -> " != "

514+ OpStrictEq -> " === "

515+ OpStrictNEq -> " !=== "

516+ OpLAnd -> " && "

517+ OpLOr -> " || "

518+ OpMul -> " * "

519+ OpDiv -> " / "

520+ OpMod -> " % "

521+ OpSub -> " - "

522+ OpLShift -> " << "

523+ OpSpRShift -> " >> "

524+ OpZfRShift -> " >>> "

525+ OpBAnd -> " & "

526+ OpBXor -> " ^ "

527+ OpBOr -> " | "

528+ OpAdd -> " + "

src/Generate/JavaScript/BuiltIn.hs+45−12

@@ -1,17 +1,30 @@

1−module Generate.JavaScript.BuiltIn where

1+module Generate.JavaScript.BuiltIn

2+ ( character, string

3+ , list, range

4+ , recordUpdate

5+ , eq, cmp

6+ , effect, outgoingPort, incomingPort

7+ , crash

8+ )

9+ where

210

3−import Control.Arrow (first)

411import qualified Language.ECMAScript3.Syntax as JS

512

613import qualified AST.Module.Name as ModuleName

7−import Generate.JavaScript.Helpers

14+import Generate.JavaScript.Helpers ((<|), (==>), call)

15+import qualified Generate.JavaScript.Variable as Var

816import qualified Reporting.Region as R

917

1018

1119

1220utils :: String -> [JS.Expression ()] -> JS.Expression ()

1321utils func args =

14− obj ["_U", func] `call` args

22+ Var.coreNative "Utils" func `call` args

23+

24+

25+nativeList :: String -> [JS.Expression ()] -> JS.Expression ()

26+nativeList func args =

27+ Var.coreNative "List" func `call` args

1528

1629

1730

@@ -34,12 +47,12 @@ string str =

3447

3548list :: [JS.Expression ()] -> JS.Expression ()

3649list elements =

37− utils "list" [ JS.ArrayLit () elements ]

50+ nativeList "fromArray" [ JS.ArrayLit () elements ]

3851

3952

4053range :: JS.Expression () -> JS.Expression () -> JS.Expression ()

4154range low high =

42− utils "range" [ low, high ]

55+ nativeList "range" [ low, high ]

4356

4457

4558

@@ -50,7 +63,7 @@ recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expressio

5063recordUpdate record fields =

5164 utils "update"

5265 [ record

53− , JS.ObjectLit () (map (first prop) fields)

66+ , JS.ObjectLit () (map (uncurry (==>)) fields)

5467 ]

5568

5669

@@ -69,6 +82,26 @@ cmp left right =

6982

7083

7184

85+-- EFFECTS

86+

87+

88+effect :: ModuleName.Canonical -> JS.Expression ()

89+effect effectName =

90+ Var.coreNative "Platform" "leaf" <|

91+ JS.StringLit () (ModuleName.canonicalToString effectName)

92+

93+

94+outgoingPort :: String -> JS.Expression () -> JS.Expression ()

95+outgoingPort name converter =

96+ Var.coreNative "Platform" "outgoingPort" `call` [ JS.StringLit () name, converter ]

97+

98+

99+incomingPort :: String -> JS.Expression () -> JS.Expression ()

100+incomingPort name converter =

101+ Var.coreNative "Platform" "incomingPort" `call` [ JS.StringLit () name, converter ]

102+

103+

104+

72105-- CRASH

73106

74107

@@ -89,14 +122,14 @@ crash home region maybeCaseCrashValue =

89122regionToJs :: R.Region -> JS.Expression ()

90123regionToJs (R.Region start end) =

91124 JS.ObjectLit ()

92− [ ( prop "start", positionToJs start )

93− , ( prop "end", positionToJs end )

125+ [ "start" ==> positionToJs start

126+ , "end" ==> positionToJs end

94127 ]

95128

96129

97130positionToJs :: R.Position -> JS.Expression ()

98131positionToJs (R.Position line column) =

99132 JS.ObjectLit ()

100− [ ( prop "line", JS.IntLit () line )

101− , ( prop "column", JS.IntLit () column )

102− ]

133+ [ "line" ==> JS.IntLit () line

134+ , "column" ==> JS.IntLit () column

135+ ]

src/Generate/JavaScript/Expression.hs+73−23

@@ -6,21 +6,24 @@ import qualified Data.List as List

66import qualified Data.Map as Map

77import Language.ECMAScript3.Syntax

88

9−import qualified AST.Expression.General as Expr

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

1010import AST.Expression.Optimized as Opt

1111import qualified AST.Literal as L

1212import qualified AST.Module.Name as ModuleName

13+import qualified AST.Type as Type

1314import qualified AST.Variable as Var

1415import Generate.JavaScript.Helpers as Help

1516import qualified Generate.JavaScript.BuiltIn as BuiltIn

17+import qualified Generate.JavaScript.Foreign as Foreign

1618import qualified Generate.JavaScript.Literal as Literal

17−import qualified Generate.JavaScript.Port as Port

1819import qualified Generate.JavaScript.Variable as Var

1920import qualified Optimize.DecisionTree as DT

2021

2122

23+

2224-- CODE CHUNKS

2325

26+

2427data Code

2528 = JsExpr (Expression ())

2629 | JsBlock [Statement ()]

@@ -76,9 +79,11 @@ toExpr code =

7679 function [] stmts `call` []

7780

7881

82+

7983-- DEFINITIONS

8084

81−generateDef :: Opt.Def -> State Int (Statement ())

85+

86+generateDef :: Opt.Def -> State Int [Statement ()]

8287generateDef def =

8388 do (home, name, jsBody) <-

8489 case def of

@@ -88,11 +93,13 @@ generateDef def =

8893 Opt.Def (Opt.Facts home _) name body ->

8994 (,,) home name <$> generateJsExpr body

9095

91− return (Var.define name jsBody)

96+ return (Var.define home name jsBody)

97+

9298

9399

94100-- EXPRESSIONS

95101

102+

96103generateJsExpr :: Opt.Expr -> State Int (Expression ())

97104generateJsExpr optExpr =

98105 toExpr <$> generateCode optExpr

@@ -130,7 +137,7 @@ generateCode expr =

130137 let

131138 toField (field, value) =

132139 do jsValue <- generateJsExpr value

133− return (prop (Var.safe field), jsValue)

140+ return (Var.safe field ==> jsValue)

134141 in

135142 do jsFields <- mapM toField fields

136143 jsExpr $ ObjectLit () jsFields

@@ -169,7 +176,7 @@ generateCode expr =

169176 Let defs body ->

170177 do stmts <- mapM generateDef defs

171178 code <- generateCode body

172− jsBlock (stmts ++ toStatementList code)

179+ jsBlock (concat stmts ++ toStatementList code)

173180

174181 If branches finally ->

175182 generateIf branches finally

@@ -182,40 +189,69 @@ generateCode expr =

182189 jsExpr $ BuiltIn.list jsElements

183190

184191 Data tag members ->

192+ let

193+ ctor =

194+ "ctor" ==> StringLit () tag

195+

196+ toEntry entry n =

197+ ("_" ++ show n) ==> entry

198+ in

185199 do jsMembers <- mapM generateJsExpr members

186− jsExpr $ ObjectLit () (ctor : fields jsMembers)

187− where

188− ctor = (prop "ctor", StringLit () tag)

189− fields =

190− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

200+ jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])

191201

192202 DataAccess dataExpr index ->

193203 do jsDataExpr <- generateJsExpr dataExpr

194204 jsExpr $ DotRef () jsDataExpr (var ("_" ++ show index))

195205

196− GLShader _uid src _tipe ->

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

206+ Cmd moduleName ->

207+ jsExpr $ BuiltIn.effect moduleName

208+

209+ Sub moduleName ->

210+ jsExpr $ BuiltIn.effect moduleName

211+

212+ OutgoingPort name tipe ->

213+ jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)

198214

199− Port impl ->

200− case impl of

201− Expr.In name portType ->

202− jsExpr (Port.inbound name portType)

215+ IncomingPort name tipe ->

216+ do jsDecoder <- generateJsExpr (Foreign.decode tipe)

217+ jsExpr $ BuiltIn.incomingPort name jsDecoder

203218

204− Expr.Out name expr portType ->

205− do expr' <- generateJsExpr expr

206− jsExpr (Port.outbound name expr' portType)

219+ Program kind body ->

220+ generateProgram kind body

207221

208− Expr.Task name expr portType ->

209− do expr' <- generateJsExpr expr

210− jsExpr (Port.task name expr' portType)

222+ GLShader _uid src _tipe ->

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

211224

212225 Crash home region maybeBranchProblem ->

213226 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem

214227 jsExpr $ BuiltIn.crash home region maybeOptBranchProblem

215228

216229

230+

231+-- PROGRAMS

232+

233+

234+generateProgram :: Expr.Main Type.Canonical -> Opt.Expr -> State Int Code

235+generateProgram kind body =

236+ let

237+ gen fields =

238+ generateCode $ Record (("main", body) : fields)

239+ in

240+ case kind of

241+ Expr.VDom ->

242+ gen []

243+

244+ Expr.NoFlags ->

245+ gen []

246+

247+ Expr.Flags tipe ->

248+ gen [ ("flags", Foreign.decode tipe) ]

249+

250+

251+

217252-- FUNCTIONS

218253

254+

219255generateFunction :: [String] -> Opt.Expr -> State Int Code

220256generateFunction args body =

221257 do code <- generateCode body

@@ -250,8 +286,10 @@ generateFunctionWithArity rawArgs code =

250286 foldl (\body arg -> function [arg] [ReturnStmt () (Just body)]) innerBody otherArgs

251287

252288

289+

253290-- GENERATE IFS

254291

292+

255293generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code

256294generateIf givenBranches givenFinally =

257295 let

@@ -307,8 +345,10 @@ crushIfsHelp visitedBranches unvisitedBranches finally =

307345 crushIfsHelp (visiting : visitedBranches) unvisited finally

308346

309347

348+

310349-- CASE EXPRESSIONS

311350

351+

312352generateCase

313353 :: String

314354 -> Opt.Decider Opt.Choice

@@ -320,8 +360,10 @@ generateCase exprName decider jumps =

320360 foldM (goto labelRoot) decider jumps

321361

322362

363+

323364-- handle any jumps

324365

366+

325367goto :: String -> [Statement ()] -> (Int, Opt.Expr) -> State Int [Statement ()]

326368goto labelRoot deciderStmts (target, branch) =

327369 let

@@ -339,8 +381,10 @@ toLabel root target =

339381 Id () (root ++ "_" ++ show target)

340382

341383

384+

342385-- turn deciders into ifs and switches

343386

387+

344388generateDecider

345389 :: String

346390 -> String

@@ -395,8 +439,10 @@ testToExpr test =

395439 Literal.literal lit

396440

397441

442+

398443-- work with paths

399444

445+

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

401447pathToTestableExpr root path exampleTest =

402448 do accessExpr <- generateJsExpr (pathToExpr root path)

@@ -430,8 +476,10 @@ pathToExpr root fullPath =

430476 expr

431477

432478

479+

433480-- BINARY OPERATORS

434481

482+

435483binop

436484 :: Var.Canonical

437485 -> Opt.Expr

@@ -443,8 +491,10 @@ binop func left right =

443491 jsExpr (makeExpr func jsLeft jsRight)

444492

445493

494+

446495-- BINARY OPERATOR HELPERS

447496

497+

448498makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())

449499makeExpr qualifiedOp@(Var.Canonical home op) =

450500 let

src/Generate/JavaScript/Foreign.hsnew file+219

@@ -0,0 +1,219 @@

1+module Generate.JavaScript.Foreign (encode, decode) where

2+

3+import qualified Data.List as List

4+import Language.ECMAScript3.Syntax

5+

6+import qualified AST.Expression.Optimized as Opt

7+import qualified AST.Literal as Literal

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

10+import Generate.JavaScript.Helpers ((<|), (==>), function, ref, var)

11+import qualified Generate.JavaScript.Variable as Var

12+

13+

14+

15+-- ENCODE

16+

17+

18+encode :: T.Canonical -> Expression ()

19+encode tipe =

20+ function ["v"] [ ReturnStmt () (Just (encodeHelp tipe (ref "v"))) ]

21+

22+

23+encodeHelp :: T.Canonical -> Expression () -> Expression ()

24+encodeHelp tipe expr =

25+ case tipe of

26+ T.Aliased _ args t ->

27+ encodeHelp (T.dealias args t) expr

28+

29+ T.Lambda _ _ ->

30+ error "encodeHelp: function"

31+

32+ T.Var _ ->

33+ error "encodeHelp: type variable"

34+

35+ T.Type name

36+ | Var.isPrim "Float" name -> expr

37+ | Var.isPrim "Int" name -> expr

38+ | Var.isPrim "Bool" name -> expr

39+ | Var.isPrim "String" name -> expr

40+ | Var.isJson name -> expr

41+ | Var.isTuple name -> NullLit ()

42+ | otherwise -> error "encodeHelp: bad type"

43+

44+ T.App (T.Type name) [arg]

45+ | Var.isMaybe name -> fromMaybe arg expr

46+ | Var.isList name -> fromList arg expr

47+ | Var.isArray name -> fromArray arg expr

48+ | otherwise -> error "encodeHelp: bad union type"

49+

50+ T.App (T.Type name) args

51+ | Var.isTuple name -> fromTuple args expr

52+

53+ T.App _ _ ->

54+ error "encodeHelp: bad union type"

55+

56+ T.Record _ (Just _) ->

57+ error "encodeHelp: bad record"

58+

59+ T.Record fields Nothing ->

60+ let

61+ convert (name, tipe) =

62+ name ==> encodeHelp tipe (DotRef () expr (var name))

63+ in

64+ ObjectLit () (map convert fields)

65+

66+

67+fromMaybe :: T.Canonical -> Expression () -> Expression ()

68+fromMaybe tipe expr =

69+ CondExpr ()

70+ (InfixExpr () OpStrictEq (DotRef () expr (var "ctor")) (StringLit () "Nothing"))

71+ (NullLit ())

72+ (encodeHelp tipe (DotRef () expr (var "_0")))

73+

74+

75+fromList :: T.Canonical -> Expression () -> Expression ()

76+fromList tipe expr =

77+ let

78+ array =

79+ Var.coreNative "List" "toArray" <| expr

80+ in

81+ DotRef () array (var "map") <| encode tipe

82+

83+

84+fromArray :: T.Canonical -> Expression () -> Expression ()

85+fromArray tipe expr =

86+ let

87+ array =

88+ Var.coreNative "Array" "toJSArray" <| expr

89+ in

90+ DotRef () array (var "map") <| encode tipe

91+

92+

93+fromTuple :: [T.Canonical] -> Expression () -> Expression ()

94+fromTuple types expr =

95+ let

96+ convert subType n =

97+ encodeHelp subType $ DotRef () expr (var ('_':show n))

98+ in

99+ ArrayLit () (zipWith convert types [0..])

100+

101+

102+

103+-- SUBSCRIPTIONS

104+

105+

106+decode :: T.Canonical -> Opt.Expr

107+decode tipe =

108+ case tipe of

109+ T.Lambda _ _ ->

110+ error "functions should not be allowed through input ports"

111+

112+ T.Var _ ->

113+ error "type variables should not be allowed through input ports"

114+

115+ T.Aliased _ args t ->

116+ decode (T.dealias args t)

117+

118+ T.Type name

119+ | Var.isPrim "Float" name -> to "float"

120+ | Var.isPrim "Int" name -> to "int"

121+ | Var.isPrim "Bool" name -> to "bool"

122+ | Var.isPrim "String" name -> to "string"

123+ | Var.isJson name -> to "value"

124+ | Var.isTuple name -> toTuple0

125+ | otherwise -> error "decode: bad type"

126+

127+ T.App (T.Type name) [arg]

128+ | Var.isMaybe name -> toMaybe arg

129+ | Var.isList name -> to "list" <== [decode arg]

130+ | Var.isArray name -> to "array" <== [decode arg]

131+ | otherwise -> error "decode: bad union type"

132+

133+ T.App (T.Type name) args

134+ | Var.isTuple name -> toTuple args

135+

136+ T.App _ _ ->

137+ error "decode: bad union type"

138+

139+ T.Record _ (Just _) ->

140+ error "decode: bad record"

141+

142+ T.Record fields Nothing ->

143+ toRecord fields

144+

145+

146+-- DECODE HELPERS

147+

148+

149+inJsonDecode :: String -> Var.Canonical

150+inJsonDecode name =

151+ Var.inCore ["Json","Decode"] name

152+

153+

154+to :: String -> Opt.Expr

155+to name =

156+ Opt.Var (inJsonDecode name)

157+

158+

159+(=:) :: String -> Opt.Expr -> Opt.Expr

160+(=:) name decoder =

161+ Opt.Binop (inJsonDecode ":=") (Opt.Literal (Literal.Str name)) decoder

162+

163+

164+(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr

165+(<==) func args =

166+ Opt.Call func args

167+

168+

169+

170+-- COMPLEX DECODE HELPERS

171+

172+

173+toMaybe :: T.Canonical -> Opt.Expr

174+toMaybe tipe =

175+ let

176+ maybe tag =

177+ Opt.Var (Var.inCore ["Maybe"] tag)

178+ in

179+ to "oneOf" <==

180+ [ Opt.ExplicitList

181+ [ to "null" <== [ maybe "Nothing" ]

182+ , to "map" <== [ maybe "Just", decode tipe ]

183+ ]

184+ ]

185+

186+

187+toTuple0 :: Opt.Expr

188+toTuple0 =

189+ to "null" <== [Opt.Var (Var.builtin "_Tuple0")]

190+

191+

192+toTuple :: [T.Canonical] -> Opt.Expr

193+toTuple types =

194+ let

195+ size =

196+ length types

197+

198+ args =

199+ map (\n -> 'x' : show n) [ 1 .. size ]

200+

201+ makeTuple =

202+ Opt.Function args (Opt.Data ("_Tuple" ++ show size) (map (Opt.Var . Var.local) args))

203+ in

204+ to ("tuple" ++ show size) <== (makeTuple : map decode types)

205+

206+

207+toRecord :: [(String, T.Canonical)] -> Opt.Expr

208+toRecord fields =

209+ let

210+ toFieldExpr (key, _) =

211+ (key, Opt.Var (Var.local key))

212+

213+ finalDecoder =

214+ to "succeed" <== [ Opt.Record (map toFieldExpr fields) ]

215+

216+ andThen (key, tipe) decoder =

217+ to "andThen" <== [ key =: decode tipe, Opt.Function [key] decoder ]

218+ in

219+ List.foldr andThen finalDecoder fields

src/Generate/JavaScript/Helpers.hs+10−31

@@ -3,6 +3,7 @@ module Generate.JavaScript.Helpers where

33import Language.ECMAScript3.Syntax

44

55

6+

67localRuntime :: String

78localRuntime =

89 "_elm"

@@ -13,18 +14,15 @@ varDecl x expr =

1314 VarDecl () (var x) (Just expr)

1415

1516

16−make :: [String] -> Expression ()

17−make moduleName =

18− obj (moduleName ++ ["make"]) <| ref localRuntime

19−

17+refOrObject :: String -> Expression ()

18+refOrObject name =

19+ InfixExpr () OpLOr (ref name) (ObjectLit () [])

2020

21−useLazy :: [String] -> String -> Expression ()

22−useLazy moduleName functionName =

23− DotRef () (make moduleName) (var functionName)

2421

2522

2623-- Creating Variables

2724

25+

2826var :: String -> Id ()

2927var name =

3028 Id () name

@@ -35,9 +33,9 @@ ref name =

3533 VarRef () (var name)

3634

3735

38−prop :: String -> Prop ()

39−prop name =

40− PropId () (var name)

36+(==>) :: String -> Expression () -> (Prop (), Expression ())

37+(==>) name expr =

38+ ( PropId () (var name), expr )

4139

4240

4341obj :: [String] -> Expression ()

@@ -50,8 +48,10 @@ obj vars =

5048 error "dotSep must be called on a non-empty list of variables"

5149

5250

51+

5352-- Function Calls

5453

54+

5555(<|) :: Expression () -> Expression () -> Expression ()

5656(<|) f x =

5757 CallExpr () f [x]

@@ -66,24 +66,3 @@ call :: Expression () -> [Expression ()] -> Expression ()

6666call =

6767 CallExpr ()

6868

69−

70−-- Checks

71−

72−equal :: Expression () -> Expression () -> Expression ()

73−equal a b =

74− InfixExpr () OpStrictEq a b

75−

76−

77−instanceof :: String -> Expression () -> Expression ()

78−instanceof tipe x =

79− InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

80−

81−

82−typeof :: String -> Expression () -> Expression ()

83−typeof tipe x =

84− equal (PrefixExpr () PrefixTypeof x) (StringLit () tipe)

85−

86−

87−member :: String -> Expression () -> Expression ()

88−member field x =

89− InfixExpr () OpIn (StringLit () field) x

src/Generate/JavaScript/Port.hsdeleted−299

@@ -1,299 +0,0 @@

1−module Generate.JavaScript.Port (inbound, outbound, task) where

2−

3−import qualified Data.List as List

4−import qualified Data.Map as Map

5−import Language.ECMAScript3.Syntax

6−

7−import qualified AST.Type as T

8−import qualified AST.Variable as Var

9−import Generate.JavaScript.Helpers

10−import qualified Reporting.Render.Type as RenderType

11−

12−

13−-- TASK

14−

15−task :: String -> Expression () -> T.Port t -> Expression ()

16−task name expr portType =

17− case portType of

18− T.Normal _ ->

19− _Task "perform" `call` [ expr ]

20−

21− T.Signal _ _ ->

22− _Task "performSignal" `call` [ StringLit () name, expr ]

23−

24−

25−

26−-- HELPERS

27−

28−data JSType

29− = JSNumber

30− | JSInt

31− | JSBoolean

32− | JSString

33− | JSArray

34− | JSObject [String]

35−

36−

37−typeToString :: JSType -> String

38−typeToString tipe =

39− case tipe of

40− JSNumber -> "a number"

41− JSInt -> "an integer"

42− JSBoolean -> "a boolean (true or false)"

43− JSString -> "a string"

44− JSArray -> "an array"

45− JSObject fields ->

46− "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"

47−

48−

49−_Array :: String -> Expression ()

50−_Array functionName =

51− useLazy ["Elm","Native","Array"] functionName

52−

53−

54−_List :: String -> Expression ()

55−_List functionName =

56− useLazy ["Elm","Native","List"] functionName

57−

58−

59−_Maybe :: String -> Expression ()

60−_Maybe functionName =

61− useLazy ["Elm","Maybe"] functionName

62−

63−

64−_Port :: String -> Expression ()

65−_Port functionName =

66− useLazy ["Elm","Native","Port"] functionName

67−

68−

69−_Task :: String -> Expression ()

70−_Task functionName =

71− useLazy ["Elm","Native","Task"] functionName

72−

73−

74−check :: Expression () -> JSType -> Expression () -> Expression ()

75−check x jsType continue =

76− CondExpr () (jsFold OpLOr checks x) continue throw

77− where

78− jsFold op checks value =

79− foldl1 (InfixExpr () op) (map ($ value) checks)

80−

81− throw =

82− obj ["_U","badPort"] `call` [ StringLit () (typeToString jsType), x ]

83−

84− checks =

85− case jsType of

86− JSNumber ->

87− [typeof "number"]

88−

89− JSInt ->

90− [jsFold OpLAnd intChecks]

91−

92− JSBoolean ->

93− [typeof "boolean"]

94−

95− JSString ->

96− [typeof "string", instanceof "String"]

97−

98− JSArray ->

99− [instanceof "Array"]

100−

101− JSObject fields ->

102− [jsFold OpLAnd (typeof "object" : map member fields)]

103−

104−

105−intChecks :: [Expression () -> Expression ()]

106−intChecks =

107− [ typeof "number"

108− , \x -> ref "isFinite" <| x

109− , \x -> equal (obj ["Math","floor"] <| x) x

110− ]

111−

112−

113−-- INBOUND

114−

115−inbound :: String -> T.Port T.Canonical -> Expression ()

116−inbound name portType =

117− case portType of

118− T.Normal tipe ->

119− _Port "inbound" `call`

120− [ StringLit () name

121− , StringLit () (show (RenderType.toDoc Map.empty tipe))

122− , toTypeFunction tipe

123− ]

124−

125− T.Signal _root arg ->

126− _Port "inboundSignal" `call`

127− [ StringLit () name

128− , StringLit () (show (RenderType.toDoc Map.empty arg))

129− , toTypeFunction arg

130− ]

131−

132−

133−toTypeFunction :: T.Canonical -> Expression ()

134−toTypeFunction tipe =

135− function ["v"] [ ReturnStmt () (Just (toType tipe (ref "v"))) ]

136−

137−

138−toType :: T.Canonical -> Expression () -> Expression ()

139−toType tipe x =

140− case tipe of

141− T.Lambda _ _ ->

142− error "functions should not be allowed through input ports"

143−

144− T.Var _ ->

145− error "type variables should not be allowed through input ports"

146−

147− T.Aliased _ args t ->

148− toType (T.dealias args t) x

149−

150− T.Type (Var.Canonical Var.BuiltIn name)

151− | name == "Float" -> from JSNumber

152− | name == "Int" -> from JSInt

153− | name == "Bool" -> from JSBoolean

154− | name == "String" -> from JSString

155− where

156− from checks = check x checks x

157−

158− T.Type name

159− | Var.isJson name ->

160− x

161−

162− | Var.isTuple name ->

163− toTuple [] x

164−

165− | otherwise ->

166− error "bad type got to foreign input conversion"

167−

168− T.App f args ->

169− case f : args of

170− T.Type name : [t]

171− | Var.isMaybe name ->

172− CondExpr ()

173− (equal x (NullLit ()))

174− (_Maybe "Nothing")

175− (_Maybe "Just" <| toType t x)

176−

177− | Var.isList name ->

178− check x JSArray (_List "fromArray" <| array)

179−

180− | Var.isArray name ->

181− check x JSArray (_Array "fromJSArray" <| array)

182− where

183− array = DotRef () x (var "map") <| toTypeFunction t

184−

185− T.Type name : ts

186− | Var.isTuple name ->

187− toTuple ts x

188−

189− _ -> error "bad ADT got to foreign input conversion"

190−

191− T.Record _ (Just _) ->

192− error "bad record got to foreign input conversion"

193−

194− T.Record fields Nothing ->

195− check x (JSObject (map fst fields)) object

196− where

197− object = ObjectLit () $ (prop "_", ObjectLit () []) : keys

198− keys = map convert fields

199− convert (f,t) = (prop f, toType t (DotRef () x (var f)))

200−

201−

202−toTuple :: [T.Canonical] -> Expression () -> Expression ()

203−toTuple types x =

204− check x JSArray (ObjectLit () fields)

205− where

206− fields =

207− (prop "ctor", ctor) : zipWith convert [0..] types

208−

209− ctor =

210− StringLit () ("_Tuple" ++ show (length types))

211−

212− convert n t =

213− ( prop ('_':show n)

214− , toType t (BracketRef () x (IntLit () n))

215− )

216−

217−

218−-- OUTBOUND

219−

220−outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()

221−outbound name expr portType =

222− case portType of

223− T.Normal tipe ->

224− _Port "outbound" `call` [ StringLit () name, fromTypeFunction tipe, expr ]

225−

226− T.Signal _ arg ->

227− _Port "outboundSignal" `call` [ StringLit () name, fromTypeFunction arg, expr ]

228−

229−

230−fromTypeFunction :: T.Canonical -> Expression ()

231−fromTypeFunction tipe =

232− function ["v"] [ ReturnStmt () (Just (fromType tipe (ref "v"))) ]

233−

234−

235−fromType :: T.Canonical -> Expression () -> Expression ()

236−fromType tipe x =

237− case tipe of

238− T.Aliased _ args t ->

239− fromType (T.dealias args t) x

240−

241− T.Lambda _ _

242− | numArgs > 1 && numArgs < 10 ->

243− func (ref ('A':show numArgs) `call` (x:values))

244− | otherwise ->

245− func (foldl (<|) x values)

246− where

247− ts = T.collectLambdas tipe

248− numArgs = length ts - 1

249− args = map (\n -> '_' : show n) [0..]

250− values = zipWith toType (init ts) (map ref args)

251− func body =

252− function (take numArgs args)

253− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

254− , ReturnStmt () (Just (fromType (last ts) (ref "_r")))

255− ]

256−

257− T.Var _ ->

258− error "type variables should not be allowed through outputs"

259−

260− T.Type (Var.Canonical Var.BuiltIn name)

261− | name `elem` ["Int","Float","Bool","String"] ->

262− x

263−

264− T.Type name

265− | Var.isJson name -> x

266− | Var.isTuple name -> ArrayLit () []

267− | otherwise -> error "bad type got to an output"

268−

269− T.App f args ->

270− case f : args of

271− T.Type name : [t]

272− | Var.isMaybe name ->

273− CondExpr ()

274− (equal (DotRef () x (var "ctor")) (StringLit () "Nothing"))

275− (NullLit ())

276− (fromType t (DotRef () x (var "_0")))

277−

278− | Var.isArray name ->

279− DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t

280−

281− | Var.isList name ->

282− DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t

283−

284− T.Type name : ts

285− | Var.isTuple name ->

286− let convert n t = fromType t $ DotRef () x $ var ('_':show n)

287− in ArrayLit () $ zipWith convert [0..] ts

288−

289− _ -> error "bad ADT got to an output"

290−

291− T.Record _ (Just _) ->

292− error "bad record got to an output"

293−

294− T.Record fields Nothing ->

295− ObjectLit () keys

296− where

297− keys = map convert fields

298− convert (f,t) =

299− (PropId () (var f), fromType t (DotRef () x (var f)))

src/Generate/JavaScript/Variable.hs+99−31

@@ -1,7 +1,10 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Generate.JavaScript.Variable

23 ( fresh

34 , canonical

4− , modulePrefix

5+ , qualified

6+ , native

7+ , coreNative

58 , define

69 , safe

710 )

@@ -15,11 +18,14 @@ import qualified Language.ECMAScript3.Syntax as JS

1518import qualified AST.Helpers as Help

1619import qualified AST.Module.Name as ModuleName

1720import qualified AST.Variable as Var

21+import qualified Elm.Package as Pkg

1822import qualified Generate.JavaScript.Helpers as JS

1923

2024

25+

2126-- FRESH NAMES

2227

28+

2329fresh :: State.State Int String

2430fresh =

2531 do n <- State.get

@@ -27,54 +33,111 @@ fresh =

2733 return ("_v" ++ show n)

2834

2935

36+

3037-- DEF NAMES

3138

32−define :: String -> JS.Expression () -> JS.Statement ()

33−define name body =

34− if Help.isOp name then

35− let

36− root =

37− JS.VarRef () (JS.Id () "_op")

3839

39− lvalue =

40− JS.LBracket () root (JS.StringLit () name)

40+define :: Maybe ModuleName.Canonical -> String -> JS.Expression () -> [JS.Statement ()]

41+define maybeHome name body =

42+ if not (Help.isOp name) then

43+ let

44+ jsName =

45+ maybe unqualified qualified maybeHome name

4146 in

42− JS.ExprStmt () (JS.AssignExpr () JS.OpAssign lvalue body)

47+ [ JS.VarDeclStmt () [ JS.varDecl jsName body ] ]

4348

4449 else

45− JS.VarDeclStmt () [ JS.VarDecl () (JS.Id () (safe name)) (Just body) ]

50+ case maybeHome of

51+ Nothing ->

52+ error "can only define infix operators at the top level"

53+

54+ Just home ->

55+ let

56+ opsDictName =

57+ getOpsDictName (Var.TopLevel home)

58+

59+ lvalue =

60+ JS.LBracket () (JS.ref opsDictName) (JS.StringLit () name)

61+ in

62+ [ JS.VarDeclStmt () [ JS.varDecl opsDictName (JS.refOrObject opsDictName) ]

63+ , JS.ExprStmt () (JS.AssignExpr () JS.OpAssign lvalue body)

64+ ]

65+

4666

4767

4868-- INSTANTIATE VARIABLES

4969

70+

5071canonical :: Var.Canonical -> JS.Expression ()

5172canonical (Var.Canonical home name) =

5273 if Help.isOp name then

53− JS.BracketRef () (addRoot home "_op") (JS.StringLit () name)

74+ JS.BracketRef () (JS.ref (getOpsDictName home)) (JS.StringLit () name)

5475

5576 else

56− addRoot home (safe name)

77+ case home of

78+ Var.Local ->

79+ JS.ref (unqualified name)

80+

81+ Var.BuiltIn ->

82+ JS.ref (unqualified name)

83+

84+ Var.Module moduleName@(ModuleName.Canonical _ rawName) ->

85+ if ModuleName.isNative rawName then

86+ native moduleName name

87+

88+ else

89+ JS.ref (qualified moduleName name)

5790

91+ Var.TopLevel moduleName ->

92+ JS.ref (qualified moduleName name)

5893

59−addRoot :: Var.Home -> String -> JS.Expression ()

60−addRoot home name =

61− case home of

62− Var.Local ->

63− JS.ref name

6494

65− Var.TopLevel _moduleName ->

66− JS.ref name

95+unqualified :: String -> String

96+unqualified =

97+ safe

6798

68− Var.BuiltIn ->

69− JS.ref name

7099

71− Var.Module (ModuleName.Canonical _ moduleName) ->

72− JS.DotRef () (JS.ref (modulePrefix moduleName)) (JS.Id () name)

100+qualified :: ModuleName.Canonical -> String -> String

101+qualified moduleName name =

102+ moduleToString moduleName ++ "$" ++ removePrimes name

73103

74104

75−modulePrefix :: ModuleName.Raw -> String

76−modulePrefix moduleName =

77− '$' : List.intercalate "$" moduleName

105+native :: ModuleName.Canonical -> String -> JS.Expression ()

106+native moduleName name =

107+ JS.obj [ moduleToString moduleName, name ]

108+

109+

110+coreNative :: String -> String -> JS.Expression ()

111+coreNative moduleName name =

112+ native (ModuleName.inCore ["Native",moduleName]) name

113+

114+

115+getOpsDictName :: Var.Home -> String

116+getOpsDictName home =

117+ let

118+ moduleName =

119+ case home of

120+ Var.Local -> error "infix operators should only be defined in top-level declarations"

121+ Var.BuiltIn -> error "there should be no built-in infix operators"

122+ Var.Module name -> name

123+ Var.TopLevel name -> name

124+ in

125+ moduleToString moduleName ++ "_ops"

126+

127+

128+moduleToString :: ModuleName.Canonical -> String

129+moduleToString (ModuleName.Canonical (Pkg.Name user project) moduleName) =

130+ let

131+ safeUser =

132+ map (swap '-' '_') user

133+

134+ safeProject =

135+ map (swap '-' '_') project

136+

137+ safeModuleName =

138+ List.intercalate "_" moduleName

139+ in

140+ '_' : safeUser ++ "$" ++ safeProject ++ "$" ++ safeModuleName

78141

79142

80143swap :: Char -> Char -> Char -> Char

@@ -82,14 +145,19 @@ swap from to c =

82145 if c == from then to else c

83146

84147

148+

85149-- SAFE NAMES

86150

151+

87152safe :: String -> String

88153safe name =

89− let saferName =

90− if Set.member name jsReserveds then '$' : name else name

91− in

92− map (swap '\'' '$') saferName

154+ removePrimes $

155+ if Set.member name jsReserveds then '$' : name else name

156+

157+

158+removePrimes :: String -> String

159+removePrimes name =

160+ map (swap '\'' '$') name

93161

94162

95163jsReserveds :: Set.Set String

src/Nitpick/Pattern.hs+1−1

@@ -20,7 +20,7 @@ data Pattern

2020 deriving (Eq)

2121

2222

23−fromCanonicalPattern :: P.CanonicalPattern -> Pattern

23+fromCanonicalPattern :: P.Canonical -> Pattern

2424fromCanonicalPattern (A.A _ pattern) =

2525 case pattern of

2626 P.Data tag patterns ->

src/Nitpick/PatternMatches.hs+46−37

@@ -22,23 +22,25 @@ import qualified Reporting.Region as Region

2222import qualified Reporting.Result as Result

2323

2424

25−patternMatches

26− :: Module.Interfaces

27− -> Module.CanonicalModule

28− -> Result.Result w Error.Error DT.VariantDict

29−patternMatches interfaces modul =

25+

26+type Result warning a =

27+ Result.Result () warning Error.Error a

28+

29+

30+patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict

31+patternMatches interfaces (Module.Module name _ info) =

3032 let

31− name = Module.name modul

32− body = Module.body modul

3333 tagDict =

34− toTagDict interfaces name (Module.datatypes body)

34+ toTagDict interfaces name (Module.unions info)

3535 in

3636 const (Map.map (Map.map length) tagDict)

37− <$> checkExpression tagDict (Module.program body)

37+ <$> checkExpression tagDict (Module.program info)

38+

3839

3940

4041-- TAG DICT

4142

43+

4244type TagDict =

4345 Map.Map Var.Home (Map.Map Tag [TagInfo])

4446

@@ -52,8 +54,8 @@ data TagInfo = TagInfo

5254 }

5355

5456

55−toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.ADTs -> TagDict

56−toTagDict interfaces localName localAdts =

57+toTagDict :: Module.Interfaces -> ModuleName.Canonical -> Module.Unions -> TagDict

58+toTagDict interfaces localName localUnions =

5759 let

5860 listTags =

5961 [ TagInfo "::" 2

@@ -76,14 +78,14 @@ toTagDict interfaces localName localAdts =

7678

7779 interfaceDict =

7880 interfaces

79− |> Map.map (toTagMapping . Module.iAdts)

81+ |> Map.map (toTagMapping . Module.iUnions)

8082 |> Map.mapKeysMonotonic Var.Module

81− |> Map.insert (Var.Module localName) (toTagMapping localAdts)

83+ |> Map.insert (Var.Module localName) (toTagMapping localUnions)

8284 in

8385 Map.union builtinDict interfaceDict

8486

8587

86−toTagMapping :: Module.ADTs -> Map.Map Tag [TagInfo]

88+toTagMapping :: Module.Unions -> Map.Map Tag [TagInfo]

8789toTagMapping adts =

8890 let

8991 toTagAndArity (_tvars, tagInfoList) =

@@ -113,12 +115,11 @@ lookupOtherTags (Var.Canonical home name) tagDict =

113115 \found."

114116

115117

118+

116119-- CHECK EXPRESSIONS

117120

118−checkExpression

119− :: TagDict

120− -> Canonical.Expr

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

121+

122+checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()

122123checkExpression tagDict (A.A region expression) =

123124 let

124125 go =

@@ -158,7 +159,7 @@ checkExpression tagDict (A.A region expression) =

158159 go body

159160 <* F.traverse_ goDef defs

160161 where

161− goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =

162+ goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =

162163 checkPatterns tagDict patRegion Error.LetBound [pattern]

163164 <* go expr

164165

@@ -180,29 +181,33 @@ checkExpression tagDict (A.A region expression) =

180181 E.Record fields ->

181182 F.traverse_ (go . snd) fields

182183

183− E.Port impl ->

184− case impl of

185− E.In _ _ ->

186− Result.ok ()

184+ E.Cmd _ ->

185+ Result.ok ()

186+

187+ E.Sub _ ->

188+ Result.ok ()

187189

188− E.Out _ expr _ ->

189− go expr

190+ E.OutgoingPort _ _ ->

191+ Result.ok ()

190192

191− E.Task _ expr _ ->

192− go expr

193+ E.IncomingPort _ _ ->

194+ Result.ok ()

195+

196+ E.Program _ _ ->

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

198+

199+ E.SaveEnv _ _ ->

200+ Result.ok ()

193201

194202 E.GLShader _ _ _ ->

195203 Result.ok ()

196204

197205

206+

198207-- CHECK PATTERNS

199208

200−checkPatterns

201− :: TagDict

202− -> Region.Region

203− -> Error.Origin

204− -> [Pattern.CanonicalPattern]

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

209+

210+checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()

206211checkPatterns tagDict region origin patterns =

207212 checkPatternsHelp tagDict region origin [Anything] patterns

208213

@@ -212,8 +217,8 @@ checkPatternsHelp

212217 -> Region.Region

213218 -> Error.Origin

214219 -> [Pattern]

215− -> [Pattern.CanonicalPattern]

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

220+ -> [Pattern.Canonical]

221+ -> Result wrn ()

217222checkPatternsHelp tagDict region origin unhandled patterns =

218223 case (unhandled, patterns) of

219224 ([], []) ->

@@ -230,9 +235,9 @@ checkPatternsHelp tagDict region origin unhandled patterns =

230235filterPatterns

231236 :: TagDict

232237 -> Region.Region

233− -> Pattern.CanonicalPattern

238+ -> Pattern.Canonical

234239 -> [Pattern]

235− -> Result.Result w Error.Error [Pattern]

240+ -> Result wrn [Pattern]

236241filterPatterns tagDict region pattern unhandled =

237242 let

238243 nitPattern =

@@ -252,8 +257,10 @@ filterPatterns tagDict region pattern unhandled =

252257 unhandled

253258

254259

260+

255261-- PATTERN INTERSECTION

256262

263+

257264intersection :: Pattern -> Pattern -> Maybe Pattern

258265intersection pattern1 pattern2 =

259266 case (pattern1, pattern2) of

@@ -309,8 +316,10 @@ intersection pattern1 pattern2 =

309316 Nothing

310317

311318

319+

312320-- PATTERN COMPLEMENT

313321

322+

314323complement :: TagDict -> Pattern -> [Pattern]

315324complement tagDict nitPattern =

316325 case nitPattern of

src/Nitpick/TopLevelTypes.hs+85−68

@@ -1,16 +1,17 @@

11{-# OPTIONS_GHC -Wall #-}

22module Nitpick.TopLevelTypes (topLevelTypes) where

33

4−import Prelude hiding (maybe)

54import qualified Data.Foldable as F

5+import Data.Map ((!))

66import qualified Data.Map as Map

77

8−import qualified AST.Expression.Valid as Valid

9−import qualified AST.Declaration as Decl

8+import qualified AST.Expression.Canonical as Can

9+import qualified AST.Expression.General as Expr

1010import qualified AST.Module.Name as ModuleName

1111import qualified AST.Pattern as P

1212import qualified AST.Type as Type

1313import qualified AST.Variable as Var

14+import qualified Canonicalize.Effects as Effects

1415import qualified Elm.Package as Pkg

1516import qualified Reporting.Annotation as A

1617import qualified Reporting.Error.Type as Error

@@ -18,91 +19,107 @@ import qualified Reporting.Result as Result

1819import qualified Reporting.Warning as Warning

1920

2021

21−topLevelTypes

22− :: Map.Map String Type.Canonical

23− -> [Decl.ValidDecl]

24− -> Result.Result Warning.Warning Error.Error ()

25−topLevelTypes typeEnv validDecls =

26− do F.traverse_ (warnMissingAnnotation typeEnv) validDecls

27− checkMainType typeEnv validDecls

2822

23+type Result =

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

2925

30−-- MISSING ANNOTATIONS

3126

32−warnMissingAnnotation

33− :: Map.Map String Type.Canonical

34− -> Decl.ValidDecl

35− -> Result.Result Warning.Warning Error.Error ()

36−warnMissingAnnotation typeEnv (A.A (region,_) decl) =

37− case decl of

38− Decl.Definition (Valid.Definition (A.A _ (P.Var name)) _ Nothing) ->

39− case Map.lookup name typeEnv of

40− Nothing ->

41− return ()

42− Just tipe ->

43− Result.warn region (Warning.MissingTypeAnnotation name tipe)

44− _ ->

45− return ()

27+type TypeDict =

28+ Map.Map String Type.Canonical

29+

30+

31+

32+-- CHECK TOP LEVEL TYPES

33+

34+

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

45+

46+ Can.YesMain before main after ->

47+ do check main

48+ <* F.traverse_ check before

49+ <* F.traverse_ check after

4650

51+ mainDef <- checkMain typeEnv main

4752

48−-- MAIN TYPE

53+ return (before ++ mainDef : after)

4954

50−checkMainType

51− :: Map.Map String Type.Canonical

52− -> [Decl.ValidDecl]

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

54−checkMainType typeEnv decls =

55− case decls of

56− A.A (region,_) (Decl.Definition (Valid.Definition (A.A _ (P.Var "main")) _ _)) : _ ->

57− case Map.lookup "main" typeEnv of

58− Nothing ->

59− return ()

6055

61− Just typeOfMain ->

62− let tipe = Type.deepDealias typeOfMain

63− in

64− if tipe `elem` validMainTypes

65− then return ()

66− else Result.throw region (Error.BadMain typeOfMain)

6756

68− _ : remainingDecls ->

69− checkMainType typeEnv remainingDecls

57+-- MISSING ANNOTATIONS

58+

59+

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

69+

70+ _ ->

71+ return ()

72+

73+

7074

71− [] ->

72− return ()

75+-- CHECK MAIN TYPE

7376

7477

75−validMainTypes :: [Type.Canonical]

76−validMainTypes =

77− [ element

78− , html

79− , signal element

80− , signal html

81− ]

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

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

80+ let

81+ mainType =

82+ typeEnv ! "main"

8283

84+ makeError tipe maybeMsg =

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

8386

84−html :: Type.Canonical

85−html =

86− Type.Type (Var.fromModule virtualDom "Node")

87+ getMainKind =

88+ case Type.deepDealias mainType of

89+ Type.App name [arg]

90+ | name == vdomNode ->

91+ return Expr.VDom

8792

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

94+ return Expr.NoFlags

8895

89−virtualDom :: ModuleName.Canonical

90−virtualDom =

91− ModuleName.Canonical (Pkg.Name "evancz" "virtual-dom") ["VirtualDom"]

96+ | name == program ->

97+ return (Expr.Flags arg)

98+ <* Effects.checkPortType makeError arg

9299

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)

93106

94−element :: Type.Canonical

95−element =

96− core ["Graphics","Element"] "Element"

97107

108+program :: Type.Canonical

109+program =

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

98111

99−signal :: Type.Canonical -> Type.Canonical

100−signal tipe =

101− Type.App (core ["Signal"] "Signal") [ tipe ]

102112

113+never :: Type.Canonical

114+never =

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

103116

104−core :: [String] -> String -> Type.Canonical

105−core home name =

106− Type.Type (Var.inCore home name)

107117

118+vdomNode :: Type.Canonical

119+vdomNode =

120+ let

121+ vdom =

122+ ModuleName.Canonical Pkg.virtualDom ["VirtualDom"]

123+ in

124+ Type.Type (Var.fromModule vdom "Node")

108125

src/Optimize.hs+52−57

@@ -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,26 +22,9 @@ import qualified Reporting.Region as R

2322-- OPTIMIZE

2423

2524

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

27−optimize variantDict module_@(Module.Module home _ _ _ _ body) =

28− let

29− (defs, _) =

30− flattenLets [] (Module.program body)

31−

32− optDefs =

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

34− in

35− module_ { Module.body = body { Module.program = optDefs } }

36−

37−

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

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

40− case expr of

41− Expr.Let ds body ->

42− flattenLets (defs ++ ds) body

43−

44− _ ->

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

4628

4729

4830

@@ -50,25 +32,27 @@ flattenLets defs annExpr@(A.A _ expr) =

5032

5133

5234optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]

53−optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =

35+optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =

5436 let

5537 (args, canBody) =

5638 Expr.collectLambdas expression

57− in

58− do home <-

59− if isRoot then

60− Just <$> Env.getHome

61− else

62− return Nothing

6339

40+ maybeGetHome =

41+ if isRoot then

42+ Just <$> Env.getHome

43+

44+ else

45+ return Nothing

46+ in

47+ do home <- maybeGetHome

6448 optimizeDefHelp home deps pattern args canBody

6549

6650

6751optimizeDefHelp

6852 :: Maybe ModuleName.Canonical

6953 -> [Var.TopLevel]

70− -> P.CanonicalPattern

71− -> [P.CanonicalPattern]

54+ -> P.Canonical

55+ -> [P.Canonical]

7256 -> Can.Expr

7357 -> Env.Optimizer [Opt.Def]

7458optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =

@@ -118,7 +102,7 @@ optimizeDefHelp home deps pattern@(A.A _ ptrn) args rawBody =

118102

119103optimizeFunction

120104 :: Maybe String

121− -> [P.CanonicalPattern]

105+ -> [P.Canonical]

122106 -> Can.Expr

123107 -> Env.Optimizer ([String], Opt.Expr)

124108optimizeFunction maybeName patterns givenBody =

@@ -132,20 +116,13 @@ makeContext argNames name =

132116 Just (name, length argNames, argNames)

133117

134118

135−depatternArgs

136− :: ([String], Can.Expr)

137− -> P.CanonicalPattern

138− -> Env.Optimizer ([String], Can.Expr)

119+depatternArgs :: ([String], Can.Expr) -> P.Canonical -> Env.Optimizer ([String], Can.Expr)

139120depatternArgs (names, rawExpr) ptrn =

140121 do (name, expr) <- depattern ptrn rawExpr

141122 return (name : names, expr)

142123

143124

144−patternToDefs

145− :: Maybe ModuleName.Canonical

146− -> String

147− -> P.CanonicalPattern

148− -> [Opt.Def]

125+patternToDefs :: Maybe ModuleName.Canonical -> String -> P.Canonical -> [Opt.Def]

149126patternToDefs home rootName pattern =

150127 let

151128 (deps, rootExpr) =

@@ -166,9 +143,11 @@ patternToDefs home rootName pattern =

166143 map toDef (patternToSubstitutions rootExpr pattern)

167144

168145

146+

169147-- TURN A PATTERN INTO A BUNCH OF SUBSTITUTIONS

170148

171−patternToSubstitutions :: Opt.Expr -> P.CanonicalPattern -> [(String, Opt.Expr)]

149+

150+patternToSubstitutions :: Opt.Expr -> P.Canonical -> [(String, Opt.Expr)]

172151patternToSubstitutions expr (A.A _ pattern) =

173152 case pattern of

174153 P.Var name ->

@@ -190,8 +169,10 @@ patternToSubstitutions expr (A.A _ pattern) =

190169 concat (zipWith (patternToSubstitutions . Opt.DataAccess expr) [0..] patterns)

191170

192171

172+

193173-- OPTIMIZE EXPRESSIONS

194174

175+

195176type Context = Maybe (String, Int, [String])

196177

197178

@@ -301,20 +282,26 @@ optimizeExpr context annExpr@(A.A region expression) =

301282 Opt.Record

302283 <$> T.traverse (mapSnd justConvert) fields

303284

304− Expr.GLShader uid src gltipe ->

305− pure (Opt.GLShader uid src gltipe)

285+ Expr.Cmd moduleName ->

286+ pure (Opt.Cmd moduleName)

287+

288+ Expr.Sub moduleName ->

289+ pure (Opt.Sub moduleName)

290+

291+ Expr.OutgoingPort name tipe ->

292+ pure (Opt.OutgoingPort name tipe)

306293

307− Expr.Port impl ->

308− Opt.Port <$>

309− case impl of

310− Expr.In name tipe ->

311− pure (Expr.In name tipe)

294+ Expr.IncomingPort name tipe ->

295+ pure (Opt.IncomingPort name tipe)

312296

313− Expr.Out name expr tipe ->

314− (\e -> Expr.Out name e tipe) <$> justConvert expr

297+ Expr.Program kind expr ->

298+ Opt.Program kind <$> justConvert expr

315299

316− Expr.Task name expr tipe ->

317− (\e -> Expr.Task name e tipe) <$> justConvert expr

300+ Expr.SaveEnv _ _ ->

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

302+

303+ Expr.GLShader uid src gltipe ->

304+ pure (Opt.GLShader uid src gltipe)

318305

319306

320307mapSnd :: M.Functor box => (a -> box b) -> (x, a) -> box (x, b)

@@ -322,14 +309,16 @@ mapSnd func (x, a) =

322309 (,) x <$> func a

323310

324311

312+

325313-- OPTIMIZE CASE BRANCHES

326314

315+

327316optimizeBranch

328317 :: Context

329318 -> R.Region

330319 -> String

331− -> (P.CanonicalPattern, Can.Expr)

332− -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

320+ -> (P.Canonical, Can.Expr)

321+ -> Env.Optimizer (P.Canonical, Opt.Expr)

333322optimizeBranch context region exprName (rawPattern, canBranch) =

334323 let

335324 root =

@@ -346,9 +335,9 @@ optimizeBranch context region exprName (rawPattern, canBranch) =

346335

347336tagCrashBranch

348337 :: R.Region

349− -> P.CanonicalPattern

338+ -> P.Canonical

350339 -> Opt.Expr

351− -> Env.Optimizer (P.CanonicalPattern, Opt.Expr)

340+ -> Env.Optimizer (P.Canonical, Opt.Expr)

352341tagCrashBranch region pattern@(A.A pr _) expr =

353342 case expr of

354343 Opt.Call (Opt.Crash home _ _) [arg] ->

@@ -362,8 +351,10 @@ tagCrashBranch region pattern@(A.A pr _) expr =

362351 return (pattern, expr)

363352

364353

354+

365355-- DETECT TAIL CALL

366356

357+

367358isTailCall :: Context -> Can.Expr -> Int -> Maybe (String, [String])

368359isTailCall context (A.A _ function) arity =

369360 case (context, function) of

@@ -379,12 +370,14 @@ isTailCall context (A.A _ function) arity =

379370 Nothing

380371

381372

373+

382374-- DEPATTERN

383375-- given a pattern and an expression, push the actual pattern matching into the

384376-- expression as a case-expression if necessary. The pattern compiler will work

385377-- it out from there

386378

387−depattern :: P.CanonicalPattern -> Can.Expr -> Env.Optimizer (String, Can.Expr)

379+

380+depattern :: P.Canonical -> Can.Expr -> Env.Optimizer (String, Can.Expr)

388381depattern canPattern@(A.A _ pattern) expr =

389382 let

390383 ann =

@@ -424,8 +417,10 @@ depattern canPattern@(A.A _ pattern) expr =

424417 caseify

425418

426419

420+

427421-- OPTIMIZE BINOPS

428422

423+

429424optimizeBinop

430425 :: Context

431426 -> R.Region

src/Optimize/Case.hs+1−1

@@ -15,7 +15,7 @@ import qualified Optimize.DecisionTree as DT

1515-- OPTIMIZE A CASE EXPRESSION

1616

1717

18−optimize :: DT.VariantDict -> String -> [(P.CanonicalPattern, Opt.Expr)] -> Opt.Expr

18+optimize :: DT.VariantDict -> String -> [(P.Canonical, Opt.Expr)] -> Opt.Expr

1919optimize variantDict exprName optBranches =

2020 let

2121 (patterns, indexedBranches) =

src/Optimize/DecisionTree.hs+17−12

@@ -24,7 +24,7 @@ import qualified AST.Variable as Var

2424import qualified Reporting.Annotation as A

2525

2626

27−type CPattern = P.CanonicalPattern

27+type CPattern = P.Canonical

2828

2929

3030-- COMPILE CASES

@@ -431,19 +431,24 @@ addWeights toWeight paths =

431431

432432

433433bests :: [(Path, Int)] -> [Path]

434−bests ((path,weight):weightedPaths) =

435− let

436− gatherMinimum acc@(minWeight, paths) (path, weight) =

437− if weight == minWeight then

438− (minWeight, path : paths)

434+bests allPaths =

435+ case allPaths of

436+ [] ->

437+ error "Cannot choose the best of zero paths. This should never happen."

439438

440− else if weight < minWeight then

441− (weight, [path])

439+ (headPath, headWeight) : weightedPaths ->

440+ let

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

442+ if weight == minWeight then

443+ (minWeight, path : paths)

442444

443− else

444− acc

445− in

446− snd (List.foldl' gatherMinimum (weight, [path]) weightedPaths)

445+ else if weight < minWeight then

446+ (weight, [path])

447+

448+ else

449+ acc

450+ in

451+ snd (List.foldl' gatherMinimum (headWeight, [headPath]) weightedPaths)

447452

448453

449454-- PATH PICKING HEURISTICS

src/Optimize/Inline.hs+29−18

@@ -6,7 +6,6 @@ import Control.Monad (foldM)

66import qualified Data.List as List

77import qualified Data.Map as Map

88

9−import AST.Expression.General (PortImpl(..))

109import AST.Expression.Optimized (Expr(..), Decider(..), Choice(..))

1110import qualified AST.Expression.Optimized as Opt

1211import qualified AST.Variable as Var

@@ -50,8 +49,11 @@ processSubs (Subs subs defs) (name, (n, expr)) =

5049 (Map.insert name (Opt.Var (Var.local uniqueName)) subs)

5150 ((uniqueName, expr) : defs)

5251

52+

53+

5354-- HELPERS

5455

56+

5557deleteBatch :: [String] -> Map.Map String a -> Map.Map String a

5658deleteBatch names dict =

5759 List.foldl' (flip Map.delete) dict names

@@ -67,8 +69,10 @@ getDefName def =

6769 name

6870

6971

72+

7073-- COUNT VARIABLE APPEARANCES

7174

75+

7276count :: Opt.Expr -> Map.Map String Int

7377count expression =

7478 let

@@ -165,16 +169,20 @@ count expression =

165169 Record fields ->

166170 countMany (map snd fields)

167171

168− Port impl ->

169− case impl of

170− In _ _ ->

171− Map.empty

172+ Cmd _ ->

173+ Map.empty

174+

175+ Sub _ ->

176+ Map.empty

172177

173− Out _name expr _tipe ->

174− count expr

178+ OutgoingPort _ _ ->

179+ Map.empty

180+

181+ IncomingPort _ _ ->

182+ Map.empty

175183

176− Task _name expr _tipe ->

177− count expr

184+ Program _ expr ->

185+ count expr

178186

179187 GLShader _ _ _ ->

180188 Map.empty

@@ -275,17 +283,20 @@ replace substitutions expression =

275283 Record fields ->

276284 Record (map (second go) fields)

277285

278− Port impl ->

279− Port $

280− case impl of

281− In _ _ ->

282− impl

286+ Cmd _ ->

287+ expression

283288

284− Out name expr tipe ->

285− Out name (go expr) tipe

289+ Sub _ ->

290+ expression

291+

292+ OutgoingPort _ _ ->

293+ expression

294+

295+ IncomingPort _ _ ->

296+ expression

286297

287− Task name expr tipe ->

288− Task name (go expr) tipe

298+ Program kind expr ->

299+ Program kind (go expr)

289300

290301 GLShader _ _ _ ->

291302 expression

src/Parse/Declaration.hs+45−36

@@ -1,34 +1,49 @@

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

22module Parse.Declaration where

33

4−import Text.Parsec ( (<|>), (<?>), choice, digit, optionMaybe, string, try )

4+import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )

55

6−import qualified AST.Declaration as D

6+import qualified AST.Declaration as Decl

77import qualified Parse.Expression as Expr

88import Parse.Helpers as Help

99import qualified Parse.Type as Type

1010

1111

12−declaration :: IParser D.SourceDecl

12+

13+declaration :: IParser Decl.Source

1314declaration =

15+ commentOr $ addLocation $

16+ choice

17+ [ typeDecl

18+ , infixDecl

19+ , portDecl

20+ , definition

21+ ]

22+

23+

24+commentOr :: IParser a -> IParser (Decl.CommentOr a)

25+commentOr parser =

1426 choice

15− [ D.Comment <$> Help.docComment

16− , D.Decl <$> addLocation (typeDecl <|> infixDecl <|> port <|> definition)

27+ [ Decl.Comment <$> addLocation Help.docComment

28+ , Decl.Whatever <$> parser

1729 ]

1830

1931

32+

2033-- TYPE ANNOTATIONS and DEFINITIONS

2134

22−definition :: IParser D.SourceDecl'

35+

36+definition :: IParser Decl.Raw

2337definition =

24− D.Definition

25− <$> (Expr.typeAnnotation <|> Expr.definition)

26− <?> "a value definition"

38+ do def <- Expr.def <?> "a value definition"

39+ return $ Decl.Def def

40+

2741

2842

2943-- TYPE ALIAS and UNION TYPES

3044

31−typeDecl :: IParser D.SourceDecl'

45+

46+typeDecl :: IParser Decl.Raw

3247typeDecl =

3348 do try (reserved "type") <?> "a type declaration"

3449 forcedWS

@@ -41,50 +56,44 @@ typeDecl =

4156 case isAlias of

4257 Just _ ->

4358 do tipe <- Type.expr <?> "a type"

44− return (D.TypeAlias name args tipe)

59+ return $ Decl.Alias (Decl.Type name args tipe)

4560

4661 Nothing ->

4762 do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"

48− return $ D.Datatype name args tcs

63+ return $ Decl.Union (Decl.Type name args tcs)

64+

4965

5066

5167-- INFIX

5268

53−infixDecl :: IParser D.SourceDecl'

69+

70+infixDecl :: IParser Decl.Raw

5471infixDecl =

5572 expecting "an infix declaration" $

5673 do assoc <-

5774 choice

58− [ try (reserved "infixl") >> return D.L

59− , try (reserved "infixr") >> return D.R

60− , try (reserved "infix") >> return D.N

75+ [ try (reserved "infixl") >> return Decl.L

76+ , try (reserved "infixr") >> return Decl.R

77+ , try (reserved "infix") >> return Decl.N

6178 ]

6279 forcedWS

6380 n <- digit

6481 forcedWS

65− D.Fixity assoc (read [n]) <$> anyOp

82+ op <- anyOp

83+ return $ Decl.Fixity (Decl.Infix op assoc (read [n]))

6684

6785

68−-- PORT

6986

70−port :: IParser D.SourceDecl'

71−port =

87+-- FOREIGN

88+

89+

90+portDecl :: IParser Decl.Raw

91+portDecl =

7292 expecting "a port declaration" $

7393 do try (reserved "port")

74− whitespace

75− name <- lowVar

76− whitespace

77− choice [ portAnnotation name, portDefinition name ]

78− where

79− portAnnotation name =

80− do try hasType

81− whitespace

82− tipe <- Type.expr <?> "a type"

83− return (D.Port (D.PortAnnotation name tipe))

84−

85− portDefinition name =

86− do try equals

87− whitespace

88− expr <- Expr.expr

89− return (D.Port (D.PortDefinition name expr))

94+ forcedWS

95+ name <- Help.lowVar

96+ padded hasType

97+ tipe <- Type.expr

98+ return $ Decl.Port name tipe

9099

src/Parse/Expression.hs+39−17

@@ -1,4 +1,4 @@

1−module Parse.Expression (term, typeAnnotation, definition, expr) where

1+module Parse.Expression (term, annotation, definition, expr, def) where

22

33import qualified Data.List as List

44import Text.Parsec hiding (newline, spaces)

@@ -15,12 +15,15 @@ import qualified AST.Expression.General as E

1515import qualified AST.Expression.Source as Source

1616import qualified AST.Literal as L

1717import qualified AST.Pattern as P

18+import qualified AST.Type as T

1819import qualified AST.Variable as Var

1920import qualified Reporting.Annotation as A

2021

2122

23+

2224-------- Basic Terms --------

2325

26+

2427varTerm :: IParser Source.Expr'

2528varTerm =

2629 toVar <$> var

@@ -70,8 +73,10 @@ negative =

7073 nTerm

7174

7275

76+

7377-------- Complex Terms --------

7478

79+

7580listTerm :: IParser Source.Expr'

7681listTerm =

7782 shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr)

@@ -122,7 +127,6 @@ parensTerm =

122127 return (mkExpr start end)

123128

124129

125−

126130recordTerm :: IParser Source.Expr

127131recordTerm =

128132 addLocation $ brackets $ choice $

@@ -168,8 +172,10 @@ term =

168172 <?> "an expression"

169173

170174

175+

171176-------- Applications --------

172177

178+

173179appExpr :: IParser Source.Expr

174180appExpr =

175181 expecting "an expression" $

@@ -182,8 +188,10 @@ appExpr =

182188 _ -> List.foldl' (\f x -> A.merge f x $ E.App f x) t ts

183189

184190

191+

185192-------- Normal Expressions --------

186193

194+

187195expr :: IParser Source.Expr

188196expr =

189197 addLocation (choice [ letExpr, caseExpr, ifExpr ])

@@ -256,51 +264,65 @@ caseExpr =

256264 (,) p <$> expr

257265

258266

267+

259268-- LET

260269

270+

261271letExpr :: IParser Source.Expr'

262272letExpr =

263273 do try (reserved "let")

264274 whitespace

265275 defs <-

266− Indent.block $

267− do def <- typeAnnotation <|> definition

268− whitespace

269− return def

270− padded (reserved "in")

276+ Indent.block (def <* whitespace)

277+ whitespace

278+ reserved "in"

279+ whitespace

271280 E.Let defs <$> expr

272281

273282

283+def :: IParser Source.Def

284+def =

285+ choice

286+ [ annotation Source.Annotation

287+ , definition Source.Definition

288+ ]

289+

290+

291+

274292-- TYPE ANNOTATION

275293

276−typeAnnotation :: IParser Source.Def

277−typeAnnotation =

278− addLocation (Source.TypeAnnotation <$> try start <*> Type.expr)

279− where

294+

295+annotation :: (String -> T.Raw -> a) -> IParser (A.Located a)

296+annotation creator =

297+ let

280298 start =

281299 do v <- lowVar <|> parens symOp

282300 padded hasType

283301 return v

302+ in

303+ addLocation (creator <$> try start <*> Type.expr)

304+

284305

285306

286307-- DEFINITION

287308

288−definition :: IParser Source.Def

289−definition =

309+

310+definition :: (P.Raw -> Source.Expr -> a) -> IParser (A.Located a)

311+definition creator =

290312 addLocation $

291313 Indent.withPos $

292314 do (name, args) <- defStart

293315 padded equals

294316 body <- expr

295− return . Source.Definition name $ makeFunction args body

317+ return . creator name $ makeFunction args body

296318

297319

298−makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

320+makeFunction :: [P.Raw] -> Source.Expr -> Source.Expr

299321makeFunction args body@(A.A ann _) =

300− foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args

322+ foldr (\arg body' -> A.A ann $ E.Lambda arg body') body args

301323

302324

303−defStart :: IParser (P.RawPattern, [P.RawPattern])

325+defStart :: IParser (P.Raw, [P.Raw])

304326defStart =

305327 expecting "the definition of a value (x = ...)" $

306328 do starter <- try Pattern.term <|> addLocation (P.Var <$> parens symOp)

src/Parse/Helpers.hs+3−4

@@ -29,10 +29,9 @@ reserveds =

2929 , "let", "in"

3030 , "type"

3131 , "module", "where"

32− , "import", "as", "hiding", "exposing"

33− , "port", "export", "foreign"

34− , "perform"

35− , "deriving"

32+ , "import", "exposing"

33+ , "as"

34+ , "port"

3635 ]

3736

3837

src/Parse/Module.hs+83−19

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

12module Parse.Module (moduleDecl, header, getModuleName) where

23

34import Text.Parsec hiding (newline, spaces)

@@ -6,49 +7,112 @@ import Parse.Helpers

67import qualified AST.Module as Module

78import qualified AST.Module.Name as ModuleName

89import qualified AST.Variable as Var

9−import Reporting.Annotation as A

10+import qualified Reporting.Annotation as A

11+import qualified Reporting.Region as R

1012

1113

1214getModuleName :: String -> Maybe String

1315getModuleName source =

14− case iParse getModuleName source of

15− Right name ->

16+ let

17+ minimalParser =

18+ do optional freshLine

19+ (ModuleDecl _ names _ _) <- moduleDecl

20+ return (ModuleName.toString names)

21+ in

22+ case iParse minimalParser source of

23+ Right name ->

1624 Just name

1725

18− Left _ ->

26+ Left _ ->

1927 Nothing

20− where

21− getModuleName =

22− do optional freshLine

23− (names, _) <- moduleDecl

24− return (ModuleName.toString names)

2528

2629

2730header :: IParser (Module.Header [Module.UserImport])

2831header =

2932 do optional freshLine

30− (names, exports) <-

31− option (["Main"], Var.openListing) (moduleDecl `followedBy` freshLine)

33+ (ModuleDecl tag names exports settings) <-

34+ option

35+ (ModuleDecl Module.Normal ["Main"] Var.openListing Module.emptySettings)

36+ (moduleDecl `followedBy` freshLine)

37+

3238 docs <-

3339 choice

3440 [ addLocation (Just <$> docComment) `followedBy` freshLine

3541 , addLocation (return Nothing)

3642 ]

43+

3744 imports' <- imports

38− return (Module.Header names docs exports imports')

3945

46+ return (Module.Header tag names exports settings docs imports')

47+

48+

49+data ModuleDecl =

50+ ModuleDecl

51+ { _tag :: Module.SourceTag

52+ , _name :: [String]

53+ , _exports :: Var.Listing (A.Located Var.Value)

54+ , _settings :: Module.SourceSettings

55+ }

4056

41−moduleDecl :: IParser ([String], Var.Listing (A.Located Var.Value))

57+

58+moduleDecl :: IParser ModuleDecl

4259moduleDecl =

4360 expecting "a module declaration" $

44− do try (reserved "module")

61+ do

62+ tag <- parseTag

4563 whitespace

64+

4665 names <- dotSep1 capVar <?> "the name of this module"

4766 whitespace

48− exports <- option Var.openListing (listing (addLocation value))

67+

68+ settings <-

69+ case tag of

70+ Module.Effect _ ->

71+ parseSetting <* whitespace

72+

73+ _ ->

74+ return Module.emptySettings

75+

76+ reserved "exposing" <?> "something like `exposing (..)` which replaced `where` in 0.17"

77+ whitespace

78+

79+ exports <- listing (addLocation value)

80+

81+ return (ModuleDecl tag names exports settings)

82+

83+

84+parseTag :: IParser Module.SourceTag

85+parseTag =

86+ choice

87+ [

88+ do try (reserved "module")

89+ return Module.Normal

90+ ,

91+ do start <- getMyPosition

92+ try (reserved "effect")

93+ whitespace

94+ reserved "module"

95+ end <- getMyPosition

96+ return (Module.Effect (R.Region start end))

97+ ,

98+ do start <- getMyPosition

99+ try (reserved "port")

100+ whitespace

101+ reserved "module"

102+ end <- getMyPosition

103+ return (Module.Port (R.Region start end))

104+ ]

105+

106+

107+parseSetting :: IParser Module.SourceSettings

108+parseSetting =

109+ do try (reserved "where")

49110 whitespace

50− reserved "where"

51− return (names, exports)

111+ addLocation $ brackets $ commaSep $

112+ do name <- addLocation lowVar

113+ padded equals

114+ typeName <- addLocation capVar

115+ return (name, typeName)

52116

53117

54118imports :: IParser [Module.UserImport]

@@ -89,14 +153,14 @@ listing item =

89153 expecting "a listing of values and types to expose, like (..)" $

90154 do try (whitespace >> char '(')

91155 whitespace

92− listing <-

156+ actualListing <-

93157 choice

94158 [ const Var.openListing <$> string ".."

95159 , Var.Listing <$> commaSep1 item <*> return False

96160 ]

97161 whitespace

98162 char ')'

99− return listing

163+ return actualListing

100164

101165

102166value :: IParser Var.Value

src/Parse/Parse.hs+40−46

@@ -1,4 +1,4 @@

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

22module Parse.Parse (program, parse) where

33

44import qualified Data.Map as Map

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

66import Text.Parsec (char, eof, letter, many, putState, (<|>))

77import qualified Text.Parsec.Error as Parsec

88

9−import qualified AST.Declaration as D

10−import qualified AST.Module as M

9+import qualified AST.Declaration as Decl

10+import qualified AST.Module as Module

1111import qualified AST.Module.Name as ModuleName

12−import qualified Elm.Compiler.Imports as Imports

1312import qualified Elm.Package as Package

1413import Parse.Helpers

15−import qualified Parse.Module as Module

16−import qualified Parse.Declaration as Decl

14+import qualified Parse.Module as Parse (header)

15+import qualified Parse.Declaration as Parse (declaration, infixDecl)

1716import qualified Reporting.Region as R

1817import qualified Reporting.Error.Syntax as Error

1918import qualified Reporting.Result as Result

2019import qualified Validate

2120

2221

23−program

24− :: Package.Name

25− -> Bool

26− -> OpTable

27− -> String

28− -> Result.Result wrn Error.Error M.ValidModule

29−program pkgName isRoot table src =

30− do (M.Module name filePath docs exports imports sourceDecls) <-

31− parseWithTable table src (programParser pkgName)

3222

33− validDecls <- Validate.declarations isRoot sourceDecls

23+program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid

24+program pkgName table src =

25+ do modul <-

26+ parseWithTable table src (programParser pkgName)

3427

35− -- determine if default imports should be added, only elm-lang/core is exempt

36− let ammendedImports =

37− ( if pkgName == Package.coreName then [] else Imports.defaults

38− , imports

39− )

28+ Validate.module' modul

4029

41− return (M.Module name filePath docs exports ammendedImports validDecls)

4230

4331

4432-- HEADERS AND DECLARATIONS

4533

46−programParser :: Package.Name -> IParser M.SourceModule

34+

35+programParser :: Package.Name -> IParser Module.Source

4736programParser pkgName =

48− do (M.Header name docs exports imports) <- Module.header

49− decls <- declarations

50− _ <- many (spaces <|> newline)

51− eof

37+ do (Module.Header tag name exports settings docs imports) <-

38+ Parse.header

39+

40+ decls <-

41+ declarations

42+

43+ many (spaces <|> newline)

5244

53− let canonicalName =

54− ModuleName.Canonical pkgName name

45+ eof

5546

56− return $ M.Module canonicalName "" docs exports imports decls

47+ return $

48+ Module.Module

49+ (ModuleName.Canonical pkgName name)

50+ ""

51+ (Module.Source tag settings docs exports imports decls)

5752

5853

59−declarations :: IParser [D.SourceDecl]

54+declarations :: IParser [Decl.Source]

6055declarations =

61− (:) <$> Decl.declaration

56+ (:) <$> Parse.declaration

6257 <*> many freshDef

6358

6459

65−freshDef :: IParser D.SourceDecl

60+freshDef :: IParser Decl.Source

6661freshDef =

6762 commitIf (freshLine >> (letter <|> char '_')) $

68− do _ <- freshLine

69− Decl.declaration

63+ do freshLine

64+ Parse.declaration

65+

7066

7167

7268-- RUN PARSERS

7369

74−parse :: String -> IParser a -> Result.Result wrn Error.Error a

70+

71+parse :: String -> IParser a -> Validate.Result wrn a

7572parse source parser =

7673 case iParse parser source of

7774 Right result ->

@@ -84,11 +81,7 @@ parse source parser =

8481 Result.throw (R.Region pos pos) (Error.Parse msgs)

8582

8683

87−parseWithTable

88− :: OpTable

89− -> String

90− -> IParser a

91− -> Result.Result wrn Error.Error a

84+parseWithTable :: OpTable -> String -> IParser a -> Validate.Result wrn a

9285parseWithTable table source parser =

9386 do infixInfoList <- parse source parseFixities

9487

@@ -102,10 +95,11 @@ parseWithTable table source parser =

10295

10396-- INFIX INFO

10497

98+

10599makeInfixTable

106− :: Map.Map String (Int, D.Assoc)

100+ :: Map.Map String (Int, Decl.Assoc)

107101 -> [(String, InfixInfo)]

108− -> Result.Result wrn Error.Error (Map.Map String (Int, D.Assoc))

102+ -> Validate.Result wrn (Map.Map String (Int, Decl.Assoc))

109103makeInfixTable table newInfo =

110104 let add (op, info) dict =

111105 Map.insertWith (++) op [info] dict

@@ -135,12 +129,12 @@ parseFixities =

135129 where

136130 infics =

137131 do start <- getMyPosition

138− (D.Fixity assoc level op) <- Decl.infixDecl

132+ (Decl.Fixity (Decl.Infix op assoc level)) <- Parse.infixDecl

139133 end <- getMyPosition

140134 return (op, InfixInfo (R.Region start end) (level, assoc))

141135

142136

143137data InfixInfo = InfixInfo

144138 { _region :: R.Region

145− , _info :: (Int, D.Assoc)

146− }

139+ , _info :: (Int, Decl.Assoc)

140+ }

src/Parse/Pattern.hs+8−8

@@ -13,7 +13,7 @@ import qualified Reporting.Annotation as A

1313import qualified Reporting.Region as R

1414

1515

16−basic :: IParser P.RawPattern

16+basic :: IParser P.Raw

1717basic =

1818 addLocation $

1919 choice

@@ -37,7 +37,7 @@ basic =

3737 P.Var str

3838

3939

40−asPattern :: IParser P.RawPattern -> IParser P.RawPattern

40+asPattern :: IParser P.Raw -> IParser P.Raw

4141asPattern patternParser =

4242 do pattern <- patternParser

4343

@@ -59,13 +59,13 @@ asPattern patternParser =

5959 lowVar

6060

6161

62−record :: IParser P.RawPattern

62+record :: IParser P.Raw

6363record =

6464 addLocation

6565 (P.Record <$> brackets (commaSep1 lowVar))

6666

6767

68−tuple :: IParser P.RawPattern

68+tuple :: IParser P.Raw

6969tuple =

7070 do (start, patterns, end) <-

7171 located (parens (commaSep expr))

@@ -78,20 +78,20 @@ tuple =

7878 return (A.at start end (P.tuple patterns))

7979

8080

81−list :: IParser P.RawPattern

81+list :: IParser P.Raw

8282list =

8383 braces $

8484 do (_, patterns, end) <- located (commaSep expr)

8585 return (P.list end patterns)

8686

8787

88−term :: IParser P.RawPattern

88+term :: IParser P.Raw

8989term =

9090 choice [ record, tuple, list, basic ]

9191 <?> "a pattern"

9292

9393

94−patternConstructor :: IParser P.RawPattern

94+patternConstructor :: IParser P.Raw

9595patternConstructor =

9696 addLocation $

9797 do v <- List.intercalate "." <$> dotSep1 capVar

@@ -101,7 +101,7 @@ patternConstructor =

101101 _ -> P.Data (Var.Raw v) <$> spacePrefix term

102102

103103

104−expr :: IParser P.RawPattern

104+expr :: IParser P.Raw

105105expr =

106106 asPattern subPattern <?> "a pattern"

107107 where

src/Parse/Type.hs+2−2

@@ -2,7 +2,7 @@

22module Parse.Type where

33

44import Data.List (intercalate)

5−import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)

5+import Text.Parsec ((<|>), (<?>), char, choice, many, optionMaybe, string, try)

66

77import qualified AST.Type as Type

88import qualified AST.Variable as Var

@@ -64,7 +64,7 @@ constructor0 =

6464

6565term :: IParser Type.Raw

6666term =

67− tuple <|> record <|> tvar <|> constructor0

67+ choice [ tuple, record, tvar, constructor0 ]

6868

6969

7070app :: IParser Type.Raw

src/Reporting/Annotation.hs+6

@@ -4,8 +4,10 @@ import Prelude hiding (map)

44import qualified Reporting.Region as R

55

66

7+

78-- ANNOTATION

89

10+

911data Annotated annotation a

1012 = A annotation a

1113

@@ -18,8 +20,10 @@ type Commented a =

1820 Annotated (R.Region, Maybe String) a

1921

2022

23+

2124-- CREATE

2225

26+

2327at :: R.Position -> R.Position -> a -> Located a

2428at start end value =

2529 A (R.Region start end) value

@@ -35,8 +39,10 @@ sameAs (A annotation _) value =

3539 A annotation value

3640

3741

42+

3843-- MANIPULATE

3944

45+

4046map :: (a -> b) -> Annotated info a -> Annotated info b

4147map f (A annotation value) =

4248 A annotation (f value)

src/Reporting/Bag.hsnew file+101

@@ -0,0 +1,101 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Bag

3+ ( Bag

4+ , empty, singleton, cons, append, map

5+ , toList, fromList

6+ )

7+ where

8+

9+

10+import Prelude hiding (map)

11+

12+

13+

14+-- BAGS

15+

16+

17+data Bag a

18+ = Empty

19+ | One a

20+ | Two (Bag a) (Bag a)

21+ | Many [a]

22+

23+

24+empty :: Bag a

25+empty =

26+ Empty

27+

28+

29+singleton :: a -> Bag a

30+singleton =

31+ One

32+

33+

34+cons :: a -> Bag a -> Bag a

35+cons x bag =

36+ case bag of

37+ Empty ->

38+ One x

39+

40+ _ ->

41+ Two (One x) bag

42+

43+

44+append :: Bag a -> Bag a -> Bag a

45+append left right =

46+ case (left, right) of

47+ (other, Empty) ->

48+ other

49+

50+ (Empty, other) ->

51+ other

52+

53+ (_, _) ->

54+ Two left right

55+

56+

57+map :: (a -> b) -> Bag a -> Bag b

58+map func bag =

59+ case bag of

60+ Empty ->

61+ Empty

62+

63+ One x ->

64+ One (func x)

65+

66+ Two left right ->

67+ Two (map func left) (map func right)

68+

69+ Many xs ->

70+ Many (fmap func xs)

71+

72+

73+

74+-- LIST CONVERSIONS

75+

76+

77+fromList :: [a] -> Bag a

78+fromList =

79+ Many

80+

81+

82+toList :: (a -> b) -> Bag a -> [b]

83+toList func bag =

84+ toListHelp func bag []

85+

86+

87+toListHelp :: (a -> b) -> Bag a -> [b] -> [b]

88+toListHelp func bag list =

89+ case bag of

90+ Empty ->

91+ list

92+

93+ One x ->

94+ func x : list

95+

96+ Two left right ->

97+ toListHelp func left (toListHelp func right list)

98+

99+ Many xs ->

100+ foldr (\x newList -> func x : newList) list xs

101+

src/Reporting/Error/Canonicalize.hs+26−33

@@ -100,24 +100,17 @@ alias name expected actual =

100100-- PORTS

101101

102102

103−data PortError = PortError

103+data PortError =

104+ PortError

104105 { portName :: String

105− , portIsInbound :: Bool

106− , portRootType :: Type.Canonical

107− , portLocalType :: Type.Canonical

106+ , portType :: Type.Canonical

108107 , portMessage :: Maybe String

109108 }

110109

111110

112−port

113− :: String

114− -> Bool

115− -> Type.Canonical

116− -> Type.Canonical

117− -> Maybe String

118− -> Error

119−port name isInbound rootType localType maybeMessage =

120− Port (PortError name isInbound rootType localType maybeMessage)

111+port :: String -> Type.Canonical -> Maybe String -> Error

112+port name tipe maybeMessage =

113+ Port (PortError name tipe maybeMessage)

121114

122115

123116

@@ -228,26 +221,26 @@ toReport localizer err =

228221 ("You are trying to export `" ++ name ++ "` multiple times!")

229222 "Remove duplicates until there is only one listed."

230223

231− Port (PortError name isInbound _rootType localType maybeMessage) ->

232− let

233− boundPort =

234− if isInbound then "inbound port" else "outbound port"

235− in

236− Report.report

237− "PORT ERROR"

238− Nothing

239− ("Trying to send " ++ maybe "an unsupported type" id maybeMessage

240− ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

241− )

242− ( Help.stack

243− [ text "The specific unsupported type is:"

244− , indent 4 (RenderType.toDoc localizer localType)

245− , text ("The types of values that can flow through " ++ boundPort ++ "s include:")

246− , indent 4 $ Help.reflowParagraph $

247− "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\

248− \ Tuples, Json.Values, and concrete records."

249− ]

250− )

224+ Port (PortError name tipe maybeMessage) ->

225+ let

226+ context =

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

228+ in

229+ Report.report

230+ "PORT ERROR"

231+ Nothing

232+ ("Port `" ++ name ++ "` is trying to communicate an unsupported type."

233+ )

234+ ( Help.stack

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

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

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

238+ , indent 4 $ Help.reflowParagraph $

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

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

241+ -- TODO add a note about custom decoders and encoders when they exist!

242+ ]

243+ )

251244

252245

253246argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

src/Reporting/Error/Syntax.hs+103−28

@@ -15,10 +15,19 @@ data Error

1515 = Parse [Parsec.Message]

1616 | BadFunctionName Int

1717 | BadPattern String

18+

19+ | CommentOnNothing

20+

21+ | SettingsOnNormalModule

22+ | SettingsOnPortModule

23+ | DuplicateSettingOnEffectModule String

24+ | BadSettingOnEffectModule String

25+ | NoSettingsOnEffectModule

26+ | MissingManagerOnEffectModule String

27+ | UnexpectedPort String

28+

1829 | InfixDuplicate String

1930 | TypeWithoutDefinition String

20− | PortWithoutAnnotation String

21− | UnexpectedPort

2231 | DuplicateFieldName String

2332 | DuplicateValueDeclaration String

2433 | DuplicateTypeDeclaration String

@@ -64,6 +73,94 @@ toReport _localizer err =

6473 ]

6574 )

6675

76+ CommentOnNothing ->

77+ Report.report

78+ "STRAY COMMENT"

79+ Nothing

80+ ("This documentation comment is not followed by anything.")

81+ ( Help.reflowParagraph $

82+ "All documentation comments need to be right above the declaration they\

83+ \ describe. Maybe some code got deleted or commented out by accident? Or\

84+ \ maybe this comment is here by accident?"

85+ )

86+

87+ SettingsOnNormalModule ->

88+ Report.report

89+ "BAD MODULE DECLARATION"

90+ Nothing

91+ "A normal module can expose values, but not settings like this."

92+ ( Help.reflowParagraph $

93+ "If you want a normal module, just remove this stuff. If you want to create\

94+ \ an `effect module` you just forgot to use the `effect` keyword. In that\

95+ \ case, just change `module` to `effect module` and you should be headed in\

96+ \ the right direction!"

97+ )

98+

99+ SettingsOnPortModule ->

100+ Report.report

101+ "BAD MODULE DECLARATION"

102+ Nothing

103+ "A port module can expose values, but not have settings like this."

104+ ( Help.reflowParagraph $

105+ "If you want a port module, just remove this stuff. If you want to create\

106+ \ a custom effect module instead (which is rare) just change `port module`\

107+ \ to `effect module` and you should be headed in the right direction!"

108+ )

109+

110+ DuplicateSettingOnEffectModule name ->

111+ Report.report

112+ "EFFECT MODULE PROBLEM"

113+ Nothing

114+ ("You have defined " ++ Help.functionName name ++ " multiple times.")

115+ ( Help.reflowParagraph $

116+ "There can only be one " ++ Help.functionName name

117+ ++ " though! Remove until there is one left."

118+ )

119+

120+ BadSettingOnEffectModule name ->

121+ Report.report

122+ "EFFECT MODULE PROBLEM"

123+ Nothing

124+ ("Setting " ++ Help.functionName name ++ " is not recognized.")

125+ ( Help.reflowParagraph $

126+ "Remove this entry and you should be all set!"

127+ )

128+

129+ NoSettingsOnEffectModule ->

130+ Report.report

131+ "EFFECT MODULE PROBLEM"

132+ Nothing

133+ ("You are defining an effect module, but it has no settings.")

134+ ( Help.reflowParagraph $

135+ "If you just wanted a normal module, change the keywords `effect module`\

136+ \ to `module` and you should be all set. If you want a proper effect module,\

137+ \ you need to specify your commands and/or subscriptions. Read more about this\

138+ \ here: <TODO> (please forgive me if I forgot to fill this in!)"

139+ )

140+

141+ MissingManagerOnEffectModule name ->

142+ Report.report

143+ "EFFECT MODULE PROBLEM"

144+ Nothing

145+ ("You are defining an effect module, but there is no " ++ Help.functionName name ++ " defined.")

146+ ( Help.reflowParagraph $

147+ "There is a small set of top-level functions and values that must be defined\

148+ \ in any complete effect module. The best thing is probably to just read more\

149+ \ about effect modules here:\

150+ \ <TODO> (please forgive me if I forgot to fill this in!)"

151+ )

152+

153+ UnexpectedPort name ->

154+ Report.report

155+ "BAD PORT"

156+ Nothing

157+ ("You are declaring port " ++ Help.functionName name ++ " in a normal module.")

158+ ( Help.reflowParagraph $

159+ "All ports must be defined in a `port module`. You should probably have just\

160+ \ one of these for your project. This way all of your foreign interactions\

161+ \ stay relatively organized."

162+ )

163+

67164 InfixDuplicate opName ->

68165 Report.report

69166 "INFIX OVERLAP"

@@ -87,28 +184,6 @@ toReport _localizer err =

87184 ++ " " ++ valueName ++ " = 42"

88185 )

89186

90− PortWithoutAnnotation portName ->

91− Report.report

92− "PORT ERROR"

93− Nothing

94− ("Port `" ++ portName ++ "` does not have a type annotation!")

95− ( text $

96− "Directly above the port definition, I need something like this:\n\n"

97− ++ " port " ++ portName ++ " : Signal Int"

98− )

99−

100−

101− UnexpectedPort ->

102− Report.report

103− "PORT ERROR"

104− Nothing

105− "This module has ports, but ports can only appear in the main module."

106− ( Help.reflowParagraph $

107− "Ports in library code would create hidden dependencies where importing a\

108− \ module could bring in constraints not captured in the public API. Furthermore,\

109− \ if the module is imported twice, do we send values out the port twice?"

110− )

111−

112187 DuplicateFieldName name ->

113188 Report.report

114189 "DUPLICATE FIELD"

@@ -191,7 +266,7 @@ toReport _localizer err =

191266

192267

193268unboundTypeVars :: String -> String -> [String] -> [String] -> Report.Report

194−unboundTypeVars declKind typeName givenVars unboundVars@(tvar:_) =

269+unboundTypeVars declKind typeName givenVars unboundVars =

195270 Report.report

196271 "UNBOUND TYPE VARIABLES"

197272 Nothing

@@ -205,9 +280,9 @@ unboundTypeVars declKind typeName givenVars unboundVars@(tvar:_) =

205280 ++ map (dullyellow . text) unboundVars

206281 ++ map text ["=", "..."]

207282 , Help.reflowParagraph $

208− "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ tvar ++ "` is an Int and\

209− \ another where it is a Bool. When we explicitly list the type variables, type\

210− \ checker can see that they are actually different types."

283+ "Here's why. Imagine one `" ++ typeName ++ "` where `" ++ head unboundVars ++

284+ "` is an Int and another where it is a Bool. When we explicitly list the type\

285+ \ variables, type checker can see that they are actually different types."

211286 ]

212287 )

213288

src/Reporting/Error/Type.hs+90−5

@@ -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

@@ -72,6 +73,10 @@ data Hint

7273 | Range

7374 | Lambda

7475 | Record

76+ -- effect manager problems

77+ | Manager String

78+ | State String

79+ | SelfMsg

7580

7681

7782data Pattern

@@ -98,15 +103,34 @@ toReport localizer err =

98103 Report.report

99104 "BAD MAIN TYPE"

100105 Nothing

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

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

102107 ( Help.stack

103108 [ Help.reflowParagraph $

104− "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\

105− \ on screen, but you gave me:"

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

110+ \ screen, but you gave me:"

106111 , indent 4 (RenderType.toDoc localizer tipe)

107112 ]

108113 )

109114

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

110134

111135

112136-- TYPE MISMATCHES

@@ -281,7 +305,7 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

281305 ( cmpHint

282306 (Help.capitalize (funcName maybeName) ++ " is expecting the argument to be:")

283307 "But it is:"

284− []

308+ (functionHint maybeName)

285309 )

286310

287311 UnexpectedArg maybeName index _totalArgs region ->

@@ -295,7 +319,9 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

295319 ++ Help.ordinalize index ++ " argument to be:"

296320 )

297321 "But it is:"

298− ( if index == 1 then

322+ ( functionHint maybeName

323+ ++

324+ if index == 1 then

299325 []

300326 else

301327 [ "I always figure out the type of arguments from left to right. If an argument\

@@ -425,6 +451,45 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =

425451 []

426452 )

427453

454+ Manager name ->

455+ report

456+ Nothing

457+ ("The `" ++ name ++ "` in your effect manager has a weird type.")

458+ ( cmpHint

459+ ("Your `" ++ name ++ "` function has this type:")

460+ "But it needs to have a type like this:"

461+ [ "TODO - link to overview of effect managers"

462+ ]

463+ )

464+

465+ State name ->

466+ report

467+ Nothing

468+ ( "Your effect manager creates a certain type of state with `init`, but your `"

469+ ++ name ++ "` function expects a different kind of state."

470+ )

471+ ( cmpHint

472+ "The state created by `init` has this type:"

473+ ("But `" ++ name ++ "` expects state of this type:")

474+ [ "Make the two state types match and you should be all set!"

475+ , "TODO - link to overview of effect managers"

476+ ]

477+ )

478+

479+ SelfMsg ->

480+ report

481+ Nothing

482+ "Effect managers can send messages to themselves, but `onEffects` and `onSelfMsg` are defined for different types of self messages."

483+ ( cmpHint

484+ "The `onEffects` function can send this type of message:"

485+ "But the `onSelfMsg` function receives this type:"

486+ [ "Make the two message types match and you should be all set!"

487+ , "TODO - link to overview of effect managers"

488+ ]

489+ )

490+

491+

492+

428493

429494comparisonHint

430495 :: RenderType.Localizer

@@ -452,6 +517,7 @@ comparisonHint localizer leftType rightType leftWords rightWords finalHints =

452517

453518-- BINOP HINTS

454519

520+

455521binopHint :: Var.Canonical -> Type.Canonical -> Type.Canonical -> [String]

456522binopHint op leftType rightType =

457523 let

@@ -477,6 +543,25 @@ binopHint op leftType rightType =

477543

478544

479545

546+-- FUNCTION HINTS

547+

548+

549+functionHint :: Maybe Var.Canonical -> [String]

550+functionHint maybeName =

551+ case maybeName of

552+ Nothing ->

553+ []

554+

555+ Just name ->

556+ if Var.inHtml ["Html","App"] "program" == name then

557+ [ "Does your program have flags? Maybe you want `programWithFlags` instead."

558+ ]

559+

560+ else

561+ []

562+

563+

564+

480565-- MISMATCH HELPERS

481566

482567

src/Reporting/Render/Type.hs+4−3

@@ -87,13 +87,14 @@ type Localizer =

8787varToDoc :: Localizer -> Var.Canonical -> Doc

8888varToDoc localizer var =

8989 let

90− name = Var.toString var

90+ name =

91+ Var.toString var

9192 in

9293 if name == "_Tuple0" then

93− text "()"

94+ text "()"

9495

9596 else

96− text (maybe name id (Map.lookup name localizer))

97+ text (maybe name id (Map.lookup name localizer))

9798

9899

99100

src/Reporting/Result.hs+97−57

@@ -1,45 +1,69 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Reporting.Result where

23

3−import Control.Applicative ((<|>))

4−import qualified Control.Monad as M

54import Control.Monad.Except (Except, runExcept)

65

76import qualified Reporting.Annotation as A

7+import qualified Reporting.Bag as Bag

88import qualified Reporting.Region as R

9−import qualified Reporting.Render.Type as RenderType

109

1110

12−-- TASK

1311

14−data Result warning error result =

15− Result

16− (Maybe RenderType.Localizer, [A.Located warning])

17− (RawResult [A.Located error] result)

12+-- RESULTS

1813

1914

20−data RawResult e a

21− = Ok a

22− | Err e

15+data Result info warning error result =

16+ Result

17+ { _info :: info

18+ , _warnings :: LBag warning

19+ , _answer :: Answer (LBag error) result

20+ }

2321

2422

25−-- HELPERS

23+data Answer e a = Ok a | Err e

2624

27−ok :: a -> Result w e a

25+

26+type LBag a =

27+ Bag.Bag (A.Located a)

28+

29+

30+data One a = None | One a

31+

32+

33+

34+-- RESULT HELPERS

35+

36+

37+ok :: (Monoid i) => a -> Result i w e a

2838ok value =

29− Result (Nothing, []) (Ok value)

39+ Result mempty Bag.empty (Ok value)

3040

3141

32−throw :: R.Region -> e -> Result w e a

42+throw :: (Monoid i) => R.Region -> e -> Result i w e a

3343throw region err =

34− Result (Nothing, []) (Err [A.A region err])

44+ Result mempty Bag.empty (Err (Bag.singleton (A.A region err)))

3545

3646

37−throwMany :: [A.Located e] -> Result w e a

47+throwMany :: (Monoid i) => [A.Located e] -> Result i w e a

3848throwMany errors =

39− Result (Nothing, []) (Err errors)

49+ Result mempty Bag.empty (Err (Bag.fromList errors))

50+

51+

52+accumulate :: (Monoid i) => i -> a -> Result i w e a

53+accumulate info value =

54+ Result info Bag.empty (Ok value)

55+

4056

57+warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a

58+warn region warning a =

59+ Result mempty (Bag.singleton (A.A region warning)) (Ok a)

4160

42−from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

61+

62+

63+-- EXTRACTION HELPERS

64+

65+

66+from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a

4367from f except =

4468 case runExcept except of

4569 Right answer ->

@@ -49,66 +73,68 @@ from f except =

4973 throwMany (map (A.map f) errors)

5074

5175

52−mapError :: (e -> e') -> Result w e a -> Result w e' a

53−mapError f (Result warnings rawResult) =

54− Result warnings $

76+mapError :: (e -> e') -> Result i w e a -> Result i w e' a

77+mapError f (Result info warnings rawResult) =

78+ Result info warnings $

5579 case rawResult of

5680 Ok v ->

5781 Ok v

5882

5983 Err msgs ->

60− Err (map (A.map f) msgs)

84+ Err (Bag.map (A.map f) msgs)

6185

6286

63−warn :: R.Region -> w -> Result w e ()

64−warn region warning =

65− Result (Nothing, [A.A region warning]) (Ok ())

87+format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a

88+format func (Result _ warnings answer) =

89+ mapError func (Result mempty warnings answer)

6690

6791

68−addWarnings :: [A.Located w] -> Result w e a -> Result w e a

69−addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =

70− Result (dealiaser, newWarnings ++ warnings) rawResult

92+answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'

93+answerToEither onErr onOk answer =

94+ case answer of

95+ Ok value ->

96+ Right (onOk value)

7197

98+ Err errors ->

99+ Left (Bag.toList onErr errors)

72100

73−addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a

74−addDealiaser dealiaser (Result (_, warnings) rawResult) =

75− Result (Just dealiaser, warnings) rawResult

76101

102+oneToValue :: b -> (a -> b) -> One a -> b

103+oneToValue fallback onOne one =

104+ case one of

105+ None ->

106+ fallback

77107

78−destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b

79−destruct errFunc okFunc rawResult =

80− case rawResult of

81− Ok answer ->

82− okFunc answer

108+ One value ->

109+ onOne value

83110

84− Err errors ->

85− errFunc errors

86111

87112

88113-- EXTRA FANCY HELPERS

89114

90−instance M.Functor (Result w e) where

91− fmap func (Result warnings rawResult) =

115+

116+instance Functor (Result i w e) where

117+ fmap func (Result info warnings rawResult) =

92118 case rawResult of

93119 Ok a ->

94− Result warnings (Ok (func a))

120+ Result info warnings (Ok (func a))

95121

96122 Err msgs ->

97− Result warnings (Err msgs)

123+ Result info warnings (Err msgs)

98124

99125

100−instance Applicative (Result w e) where

126+instance (Monoid i) => Applicative (Result i w e) where

101127 pure value =

102128 ok value

103129

104− (<*>) (Result context resultFunc) (Result context' resultVal) =

105− Result (merge context context') $

130+ (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =

131+ Result (mappend info info') (Bag.append warnings warnings') $

106132 case (resultFunc, resultVal) of

107133 (Ok func, Ok val) ->

108134 Ok (func val)

109135

110136 (Err msgs, Err msgs') ->

111− Err (msgs ++ msgs')

137+ Err (Bag.append msgs msgs')

112138

113139 (Err msgs, _) ->

114140 Err msgs

@@ -117,23 +143,37 @@ instance Applicative (Result w e) where

117143 Err msgs

118144

119145

120−instance M.Monad (Result w e) where

146+instance (Monoid i) => Monad (Result i w e) where

121147 return value =

122148 ok value

123149

124− (>>=) (Result context rawResult) callback =

150+ (>>=) (Result info warnings rawResult) callback =

125151 case rawResult of

126152 Err msg ->

127− Result context (Err msg)

153+ Result info warnings (Err msg)

128154

129155 Ok value ->

130− let (Result context' rawResult') = callback value

156+ let

157+ (Result info' warnings' rawResult') =

158+ callback value

131159 in

132− Result (merge context context') rawResult'

160+ Result

161+ (mappend info info')

162+ (Bag.append warnings warnings')

163+ rawResult'

164+

165+

166+instance Monoid (One a) where

167+ mempty =

168+ None

169+

170+ mappend left right =

171+ case (left, right) of

172+ (other, None) ->

173+ other

133174

175+ (None, other) ->

176+ other

134177

135−merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])

136−merge (dealiaser, warnings) (dealiaser', warnings') =

137− ( dealiaser <|> dealiaser'

138− , warnings ++ warnings'

139− )

178+ (One _, One _) ->

179+ error "There should only be one!"

src/Type/Constrain/Effects.hsnew file+114

@@ -0,0 +1,114 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Type.Constrain.Effects (constrain) where

3+

4+import qualified Data.Map as Map

5+

6+import qualified AST.Effects as Effects

7+import qualified AST.Module.Name as ModuleName

8+import qualified Reporting.Annotation as A

9+import qualified Reporting.Error.Type as Error

10+import qualified Type.Environment as Env

11+import Type.Type

12+ ( Variable, Type, TypeConstraint, Constraint(..), Scheme(Scheme)

13+ , TermN(VarN), (==>), (<|), mkVar

14+ )

15+

16+

17+constrain

18+ :: Env.Environment

19+ -> ModuleName.Canonical

20+ -> Effects.Canonical

21+ -> IO TypeConstraint

22+constrain env moduleName effects =

23+ case effects of

24+ Effects.None ->

25+ return CSaveEnv

26+

27+ Effects.Port _ ->

28+ return CSaveEnv

29+

30+ Effects.Manager _ info ->

31+ constrainHelp env moduleName info

32+

33+

34+constrainHelp

35+ :: Env.Environment

36+ -> ModuleName.Canonical

37+ -> Effects.Info

38+ -> IO TypeConstraint

39+constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

40+ let

41+ task t =

42+ Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t

43+

44+ router msg selfMsg =

45+ Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg

46+ in

47+ do v0 <- mkVar Nothing

48+ v1 <- mkVar Nothing

49+ v2 <- mkVar Nothing

50+

51+ state0 <- mkVar Nothing

52+ state1 <- mkVar Nothing

53+ state2 <- mkVar Nothing

54+

55+ msg1 <- mkVar Nothing

56+ msg2 <- mkVar Nothing

57+

58+ selfMsg1 <- mkVar Nothing

59+ selfMsg2 <- mkVar Nothing

60+

61+ let

62+ vars =

63+ [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]

64+

65+ onEffectsType =

66+ router msg1 selfMsg1

67+ ==> addEffectArgs env moduleName managerType msg1

68+ (VarN state1 ==> task state1)

69+

70+ onSelfMsgType =

71+ router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2

72+

73+ constrains =

74+ [ CInstance tagRegion "init" (VarN v0)

75+ , CInstance tagRegion "onEffects" (VarN v1)

76+ , CInstance tagRegion "onSelfMsg" (VarN v2)

77+ , CEqual (Error.Manager "init") r0 (VarN v0) (task state0)

78+ , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType

79+ , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType

80+ , CEqual (Error.State "onEffects") r1 (VarN state0) (VarN state1)

81+ , CEqual (Error.State "onSelfMsg") r2 (VarN state0) (VarN state2)

82+ , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)

83+ ]

84+

85+ return $

86+ CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv

87+

88+

89+addEffectArgs

90+ :: Env.Environment

91+ -> ModuleName.Canonical

92+ -> Effects.ManagerType

93+ -> Variable

94+ -> Type

95+ -> Type

96+addEffectArgs env moduleName managerType msg result =

97+ let

98+ toTypeName (A.A _ name) =

99+ ModuleName.canonicalToString moduleName ++ "." ++ name

100+

101+ effectList fxName =

102+ Env.getType env "List" <|

103+ (Env.getType env (toTypeName fxName) <| VarN msg)

104+ in

105+ case managerType of

106+ Effects.CmdManager cmd ->

107+ effectList cmd ==> result

108+

109+ Effects.SubManager sub ->

110+ effectList sub ==> result

111+

112+ Effects.FxManager cmd sub ->

113+ effectList cmd ==> effectList sub ==> result

114+

src/Type/Constrain/Expression.hs+167−139

@@ -14,6 +14,7 @@ import qualified AST.Variable as V

1414import qualified Reporting.Annotation as A

1515import qualified Reporting.Error.Type as Error

1616import qualified Reporting.Region as R

17+import qualified Type.Constrain.Effects as Effects

1718import qualified Type.Constrain.Literal as Literal

1819import qualified Type.Constrain.Pattern as Pattern

1920import qualified Type.Environment as Env

@@ -21,155 +22,164 @@ import qualified Type.Fragment as Fragment

2122import Type.Type hiding (Descriptor(..))

2223

2324

25+

2426constrain

2527 :: Env.Environment

2628 -> Canonical.Expr

2729 -> Type

2830 -> IO TypeConstraint

2931constrain env annotatedExpr@(A.A region expression) tipe =

30− let list t = Env.getType env "List" <| t

31− (<?) = CInstance region

32− in

33− case expression of

34− E.Literal lit ->

35− Literal.constrain env region lit tipe

36−

37− E.GLShader _uid _src gltipe ->

38− exists $ \attr ->

39− exists $ \unif ->

40− let

41− shaderTipe a u v =

42− Env.getType env "WebGL.Shader" <| a <| u <| v

43−

44− glToType glTipe =

45− Env.getType env (Lit.glTipeName glTipe)

46−

47− makeRec accessor baseRec =

48− let decls = accessor gltipe

49− in

50− if Map.size decls == 0 then

51− baseRec

52− else

53− record (Map.map glToType decls) baseRec

54−

55− attribute = makeRec Lit.attribute attr

56− uniform = makeRec Lit.uniform unif

57− varying = makeRec Lit.varying (TermN EmptyRecord1)

58− in

59− return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

32+ let

33+ list t =

34+ Env.getType env "List" <| t

35+ in

36+ case expression of

37+ E.Literal lit ->

38+ Literal.constrain env region lit tipe

6039

61− E.Var var ->

62− let name = V.toString var

63− in

64− return (if name == E.saveEnvName then CSaveEnv else name <? tipe)

65−

66− E.Range lowExpr highExpr ->

67− existsNumber $ \n ->

68− do lowCon <- constrain env lowExpr n

69− highCon <- constrain env highExpr n

70− return $ CAnd

71− [ lowCon

72− , highCon

73− , CEqual Error.Range region (list n) tipe

74− ]

75−

76− E.ExplicitList exprs ->

77− constrainList env region exprs tipe

78−

79− E.Binop op leftExpr rightExpr ->

80− constrainBinop env region op leftExpr rightExpr tipe

81−

82− E.Lambda pattern body ->

83− exists $ \argType ->

84− exists $ \resType ->

85− do fragment <- Pattern.constrain env pattern argType

86− bodyCon <- constrain env body resType

87− let con =

88− ex (Fragment.vars fragment)

89− (CLet [monoscheme (Fragment.typeEnv fragment)]

90− (Fragment.typeConstraint fragment /\ bodyCon)

91− )

92− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe

93−

94− E.App _ _ ->

95− let

96− (f:args) = E.collectApps annotatedExpr

97− in

98− constrainApp env region f args tipe

40+ E.Cmd _ ->

41+ return CTrue

42+

43+ E.Sub _ ->

44+ return CTrue

9945

100− E.If branches finally ->

101− constrainIf env region branches finally tipe

46+ E.OutgoingPort _ _ ->

47+ return CTrue

10248

103− E.Case expr branches ->

104− constrainCase env region expr branches tipe

49+ E.IncomingPort _ _ ->

50+ return CTrue

10551

106− E.Data name exprs ->

107− do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

108− let pairs = zip exprs (map VarN vars)

109− (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

110− return $ ex vars (cs /\ name <? ctipe)

111− where

112− step (t,c) (e,x) =

113− do c' <- constrain env e x

114− return (x ==> t, c /\ c')

52+ E.Program _ _ ->

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

11554

116− E.Access expr label ->

117− exists $ \t ->

118− constrain env expr (record (Map.singleton label tipe) t)

55+ E.SaveEnv moduleName effects ->

56+ Effects.constrain env moduleName effects

11957

120− E.Update expr fields ->

121− exists $ \t ->

122− do oldVars <- mapM (\_ -> mkVar Nothing) fields

123− let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

124− cOld <- ex oldVars <$> constrain env expr (record oldFields t)

58+ E.GLShader _uid _src gltipe ->

59+ exists $ \attr ->

60+ exists $ \unif ->

61+ let

62+ shaderTipe a u v =

63+ Env.getType env "WebGL.Shader" <| a <| u <| v

12564

126− newVars <- mapM (\_ -> mkVar Nothing) fields

127− let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

128− let cNew = CEqual Error.Record region (record newFields t) tipe

65+ glToType glTipe =

66+ Env.getType env (Lit.glTipeName glTipe)

12967

130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)

68+ makeRec accessor baseRec =

69+ let decls = accessor gltipe

70+ in

71+ if Map.size decls == 0 then

72+ baseRec

73+ else

74+ record (Map.map glToType decls) baseRec

75+

76+ attribute = makeRec Lit.attribute attr

77+ uniform = makeRec Lit.uniform unif

78+ varying = makeRec Lit.varying (TermN EmptyRecord1)

79+ in

80+ return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

81+

82+ E.Var var ->

83+ return (CInstance region (V.toString var) tipe)

84+

85+ E.Range lowExpr highExpr ->

86+ existsNumber $ \n ->

87+ do lowCon <- constrain env lowExpr n

88+ highCon <- constrain env highExpr n

89+ return $ CAnd

90+ [ lowCon

91+ , highCon

92+ , CEqual Error.Range region (list n) tipe

93+ ]

94+

95+ E.ExplicitList exprs ->

96+ constrainList env region exprs tipe

97+

98+ E.Binop op leftExpr rightExpr ->

99+ constrainBinop env region op leftExpr rightExpr tipe

100+

101+ E.Lambda pattern body ->

102+ exists $ \argType ->

103+ exists $ \resType ->

104+ do fragment <- Pattern.constrain env pattern argType

105+ bodyCon <- constrain env body resType

106+ let con =

107+ ex (Fragment.vars fragment)

108+ (CLet [monoscheme (Fragment.typeEnv fragment)]

109+ (Fragment.typeConstraint fragment /\ bodyCon)

110+ )

111+ return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe

112+

113+ E.App _ _ ->

114+ let

115+ (f:args) = E.collectApps annotatedExpr

116+ in

117+ constrainApp env region f args tipe

118+

119+ E.If branches finally ->

120+ constrainIf env region branches finally tipe

121+

122+ E.Case expr branches ->

123+ constrainCase env region expr branches tipe

124+

125+ E.Data name exprs ->

126+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

127+ let pairs = zip exprs (map VarN vars)

128+ (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

129+ return $ ex vars (cs /\ CInstance region name ctipe)

130+ where

131+ step (t,c) (e,x) =

132+ do c' <- constrain env e x

133+ return (x ==> t, c /\ c')

134+

135+ E.Access expr label ->

136+ exists $ \t ->

137+ constrain env expr (record (Map.singleton label tipe) t)

138+

139+ E.Update expr fields ->

140+ exists $ \t ->

141+ do oldVars <- mapM (\_ -> mkVar Nothing) fields

142+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

143+ cOld <- ex oldVars <$> constrain env expr (record oldFields t)

131144

132− return $ cOld /\ ex newVars (CAnd (cNew : cs))

145+ newVars <- mapM (\_ -> mkVar Nothing) fields

146+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

147+ let cNew = CEqual Error.Record region (record newFields t) tipe

133148

134− E.Record fields ->

135− do vars <- Monad.forM fields (\_ -> mkVar Nothing)

136− fieldCons <-

137− Monad.zipWithM

138− (constrain env)

139− (map snd fields)

140− (map VarN vars)

141− let fields' = Map.fromList (zip (map fst fields) (map VarN vars))

142− let recordType = record fields' (TermN EmptyRecord1)

143− return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))

149+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)

144150

145− E.Let defs body ->

146− do bodyCon <- constrain env body tipe

151+ return $ cOld /\ ex newVars (CAnd (cNew : cs))

147152

148− (Info schemes rqs fqs headers c2 c1) <-

149− Monad.foldM

150− (constrainDef env)

151− (Info [] [] [] Map.empty CTrue CTrue)

152− (concatMap expandPattern defs)

153+ E.Record fields ->

154+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)

155+ fieldCons <-

156+ Monad.zipWithM

157+ (constrain env)

158+ (map snd fields)

159+ (map VarN vars)

160+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))

161+ let recordType = record fields' (TermN EmptyRecord1)

162+ return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))

153163

154− let letScheme =

155− [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

164+ E.Let defs body ->

165+ do bodyCon <- constrain env body tipe

156166

157− return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

167+ (Info schemes rqs fqs headers c2 c1) <-

168+ Monad.foldM

169+ (constrainDef env)

170+ (Info [] [] [] Map.empty CTrue CTrue)

171+ (concatMap expandPattern defs)

158172

159− E.Port impl ->

160− case impl of

161− E.In _ _ ->

162− return CTrue

173+ let letScheme =

174+ [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

163175

164− E.Out _ expr _ ->

165− constrain env expr tipe

176+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

166177

167− E.Task _ expr _ ->

168− constrain env expr tipe

169178

170179

171180-- CONSTRAIN APP

172181

182+

173183constrainApp

174184 :: Env.Environment

175185 -> R.Region

@@ -250,9 +260,9 @@ argConstraints env name region totalArgs overallVar index args =

250260

251261

252262

253−

254263-- CONSTRAIN BINOP

255264

265+

256266constrainBinop

257267 :: Env.Environment

258268 -> R.Region

@@ -285,8 +295,10 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg

285295 ]

286296

287297

298+

288299-- CONSTRAIN LISTS

289300

301+

290302constrainList

291303 :: Env.Environment

292304 -> R.Region

@@ -310,8 +322,10 @@ constrainList env region exprs tipe =

310322 CEqual Error.List region (Env.getType env "List" <| VarN var) tipe

311323

312324

325+

313326-- CONSTRAIN IF EXPRESSIONS

314327

328+

315329constrainIf

316330 :: Env.Environment

317331 -> R.Region

@@ -367,13 +381,15 @@ constrainIf env region branches finally tipe =

367381 CEqual Error.If region (VarN var) tipe

368382

369383

384+

370385-- CONSTRAIN CASE EXPRESSIONS

371386

387+

372388constrainCase

373389 :: Env.Environment

374390 -> R.Region

375391 -> Canonical.Expr

376− -> [(P.CanonicalPattern, Canonical.Expr)]

392+ -> [(P.Canonical, Canonical.Expr)]

377393 -> Type

378394 -> IO TypeConstraint

379395constrainCase env region expr branches tipe =

@@ -400,8 +416,10 @@ constrainCase env region expr branches tipe =

400416 CEqual Error.Case region tipe (VarN var)

401417

402418

419+

403420-- COLLECT PAIRS

404421

422+

405423data Pair = Pair

406424 { _index :: Int

407425 , _var1 :: Variable

@@ -423,11 +441,11 @@ pairCons region pairHint varToCon items =

423441 in

424442 case collectPairs 2 items of

425443 Nothing ->

426− do var <- mkVar Nothing

427− return ([var], [varToCon var])

444+ do var <- mkVar Nothing

445+ return ([var], [varToCon var])

428446

429447 Just (pairs, var) ->

430− return (map fst items, map pairToCon pairs ++ [varToCon var])

448+ return (map fst items, map pairToCon pairs ++ [varToCon var])

431449

432450

433451collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)

@@ -444,11 +462,15 @@ collectPairs index items =

444462 return (Pair index var var' region : pairs, summaryVar)

445463

446464

465+

447466-- EXPAND PATTERNS

448467

468+

449469expandPattern :: Canonical.Def -> [Canonical.Def]

450−expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =

451− let (A.A patternRegion pattern) = lpattern

470+expandPattern def@(Canonical.Def facts lpattern expr maybeType) =

471+ let

472+ (A.A patternRegion pattern) =

473+ lpattern

452474 in

453475 case pattern of

454476 P.Var _ ->

@@ -457,27 +479,33 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =

457479 _ ->

458480 mainDef : map toDef vars

459481 where

460− vars = P.boundVarList lpattern

482+ vars =

483+ P.boundVarList lpattern

461484

462− combinedName = "$" ++ concat vars

485+ combinedName =

486+ "$" ++ concat vars

463487

464488 pvar name =

465− A.A patternRegion (P.Var name)

489+ A.A patternRegion (P.Var name)

466490

467491 localVar name =

468− A.A patternRegion (E.localVar name)

492+ A.A patternRegion (E.localVar name)

469493

470− mainDef = Canonical.Definition facts (pvar combinedName) expr maybeType

494+ mainDef =

495+ Canonical.Def facts (pvar combinedName) expr maybeType

471496

472497 toDef name =

473− let extract =

474− E.Case (localVar combinedName) [(lpattern, localVar name)]

475− in

476− Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing

498+ let

499+ extract =

500+ E.Case (localVar combinedName) [(lpattern, localVar name)]

501+ in

502+ Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing

503+

477504

478505

479506-- CONSTRAIN DEFINITIONS

480507

508+

481509data Info = Info

482510 { iSchemes :: [TypeScheme]

483511 , iRigid :: [Variable]

@@ -489,7 +517,7 @@ data Info = Info

489517

490518

491519constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info

492−constrainDef env info (Canonical.Definition _ (A.A patternRegion pattern) expr maybeTipe) =

520+constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =

493521 let qs = [] -- should come from the def, but I'm not sure what would live there...

494522 in

495523 case (pattern, maybeTipe) of

src/Type/Constrain/Pattern.hs+1−5

@@ -14,11 +14,7 @@ import Type.Fragment

1414import Type.Type

1515

1616

17−constrain

18− :: Env.Environment

19− -> P.CanonicalPattern

20− -> Type

21− -> IO Fragment

17+constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment

2218constrain env (A.A region pattern) tipe =

2319 let

2420 equal patternError leftType rightType =

src/Type/Environment.hs+12−10

@@ -31,7 +31,7 @@ data Environment = Environment

3131 }

3232

3333

34−initialize :: [Module.CanonicalAdt] -> IO Environment

34+initialize :: [Module.CanonicalUnion] -> IO Environment

3535initialize datatypes =

3636 do types <- makeTypes datatypes

3737 let env =

@@ -43,13 +43,13 @@ initialize datatypes =

4343 return $ env { _constructor = makeConstructors env datatypes }

4444

4545

46−makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

46+makeTypes :: [Module.CanonicalUnion] -> IO TypeDict

4747makeTypes datatypes =

48− do adts <- mapM makeImported datatypes

49− bs <- mapM makeBuiltin builtins

50− return (Map.fromList (adts ++ bs))

48+ do unions <- mapM makeImported datatypes

49+ bs <- mapM makeBuiltin builtins

50+ return (Map.fromList (unions ++ bs))

5151 where

52− makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

52+ makeImported :: (V.Canonical, Module.UnionInfo V.Canonical) -> IO (String, Type)

5353 makeImported (name, _) =

5454 do tvar <- mkAtom name

5555 return (V.toString name, VarN tvar)

@@ -73,7 +73,7 @@ makeTypes datatypes =

7373

7474makeConstructors

7575 :: Environment

76− -> [Module.CanonicalAdt]

76+ -> [Module.CanonicalUnion]

7777 -> Map.Map String (IO (Int, [Variable], [Type], Type))

7878makeConstructors env datatypes =

7979 Map.fromList builtins

@@ -101,7 +101,7 @@ makeConstructors env datatypes =

101101

102102ctorToType

103103 :: Environment

104− -> (V.Canonical, Module.AdtInfo V.Canonical)

104+ -> (V.Canonical, Module.UnionInfo V.Canonical)

105105 -> [(String, IO (Int, [Variable], [Type], Type))]

106106ctorToType env (name, (tvars, ctors)) =

107107 zip (map (V.toString . fst) ctors) (map inst ctors)

@@ -176,8 +176,10 @@ instantiator env sourceType =

176176

177177instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

178178instantiatorHelp env aliasVars sourceType =

179− let go = instantiatorHelp env aliasVars

180− in

179+ let

180+ go =

181+ instantiatorHelp env aliasVars

182+ in

181183 case sourceType of

182184 T.Lambda t1 t2 ->

183185 (==>) <$> go t1 <*> go t2

src/Type/Inference.hs+18−18

@@ -5,7 +5,7 @@ import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

55import qualified Data.Map as Map

66import qualified Data.Traversable as Traverse

77

8−import AST.Module as Module

8+import qualified AST.Module as Module

99import qualified AST.Module.Name as ModuleName

1010import qualified AST.Type as Type

1111import qualified AST.Variable as Var

@@ -24,7 +24,7 @@ import System.IO.Unsafe

2424

2525infer

2626 :: Module.Interfaces

27− -> Module.CanonicalModule

27+ -> Module.Canonical

2828 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

2929infer interfaces modul =

3030 either throwError return $ unsafePerformIO $ runExceptT $

@@ -41,10 +41,10 @@ infer interfaces modul =

4141

4242genConstraints

4343 :: Module.Interfaces

44− -> Module.CanonicalModule

44+ -> Module.Canonical

4545 -> IO (Map.Map String T.Type, T.TypeConstraint)

4646genConstraints interfaces modul =

47− do env <- Env.initialize (canonicalizeAdts interfaces modul)

47+ do env <- Env.initialize (canonicalizeUnions interfaces modul)

4848

4949 ctors <-

5050 forM (Env.ctorNames env) $ \name ->

@@ -62,17 +62,17 @@ genConstraints interfaces modul =

6262 fvar <- T.mkVar Nothing

6363

6464 constraint <-

65− TcExpr.constrain env (program (body modul)) (T.VarN fvar)

65+ TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)

6666

6767 return (header, environ constraint)

6868

6969

7070canonicalizeValues

7171 :: Env.Environment

72− -> (ModuleName.Canonical, Interface)

72+ -> (ModuleName.Canonical, Module.Interface)

7373 -> IO [(String, ([T.Variable], T.Type))]

7474canonicalizeValues env (moduleName, iface) =

75− forM (Map.toList (iTypes iface)) $ \(name,tipe) ->

75+ forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->

7676 do tipe' <- Env.instantiateType env tipe Map.empty

7777 return

7878 ( ModuleName.canonicalToString moduleName ++ "." ++ name

@@ -80,24 +80,24 @@ canonicalizeValues env (moduleName, iface) =

8080 )

8181

8282

83−canonicalizeAdts :: Module.Interfaces -> Module.CanonicalModule -> [CanonicalAdt]

84−canonicalizeAdts interfaces modul =

85− localAdts ++ importedAdts

83+canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]

84+canonicalizeUnions interfaces (Module.Module name _ info) =

85+ localUnions ++ importedUnions

8686 where

87− localAdts :: [CanonicalAdt]

88− localAdts =

89− format (Module.name modul, datatypes (body modul))

87+ localUnions :: [Module.CanonicalUnion]

88+ localUnions =

89+ format (name, Module.unions info)

9090

91− importedAdts :: [CanonicalAdt]

92− importedAdts =

93− concatMap (format . second iAdts) (Map.toList interfaces)

91+ importedUnions :: [Module.CanonicalUnion]

92+ importedUnions =

93+ concatMap (format . second Module.iUnions) (Map.toList interfaces)

9494

9595

96−format :: (ModuleName.Canonical, Module.ADTs) -> [CanonicalAdt]

96+format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]

9797format (home, adts) =

9898 map canonical (Map.toList adts)

9999 where

100− canonical :: (String, AdtInfo String) -> CanonicalAdt

100+ canonical :: (String, Module.UnionInfo String) -> Module.CanonicalUnion

101101 canonical (name, (tvars, ctors)) =

102102 ( toVar name

103103 , (tvars, map (first toVar) ctors)

src/Type/Type.hs+11−12

@@ -309,22 +309,22 @@ termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

309309termToSrcType term =

310310 case term of

311311 App1 func arg ->

312− do srcFunc <- variableToSrcType func

313− srcArg <- variableToSrcType arg

314− case srcFunc of

315− T.App f args ->

316− return (T.App f (args ++ [srcArg]))

312+ do srcFunc <- variableToSrcType func

313+ srcArg <- variableToSrcType arg

314+ case srcFunc of

315+ T.App f args ->

316+ return (T.App f (args ++ [srcArg]))

317317

318− _ ->

319− return (T.App srcFunc [srcArg])

318+ _ ->

319+ return (T.App srcFunc [srcArg])

320320

321321 Fun1 a b ->

322− T.Lambda

323− <$> variableToSrcType a

324− <*> variableToSrcType b

322+ T.Lambda

323+ <$> variableToSrcType a

324+ <*> variableToSrcType b

325325

326326 EmptyRecord1 ->

327− return $ T.Record [] Nothing

327+ return $ T.Record [] Nothing

328328

329329 Record1 fields extension ->

330330 do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

@@ -455,4 +455,3 @@ getVarNamesTerm term =

455455 Record1 fields extension ->

456456 do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

457457 Set.union fieldVars <$> go extension

458−

src/Type/Unify.hs+3−1

@@ -270,6 +270,7 @@ unifyRigid context maybeSuper maybeName otherContent =

270270 mismatch context (Just (badRigid maybeName))

271271

272272

273+

273274-- UNIFY SUPER VARIABLES

274275

275276

@@ -353,7 +354,7 @@ atomMatchesSuper super name =

353354 isPrimitiveFrom ["Int", "Float", "Char", "String"] name

354355

355356 Appendable ->

356− Var.isPrim "String" name || Var.isText name

357+ Var.isPrim "String" name

357358

358359 CompAppend ->

359360 Var.isPrim "String" name

@@ -496,6 +497,7 @@ isIntFloat name otherName =

496497 Var.isPrim "Int" name && Var.isPrim "Float" otherName

497498

498499

500+

499501-- UNIFY ALIASES

500502

501503

src/Validate.hs+478−251

@@ -1,18 +1,25 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Validate (declarations) where

2+module Validate (Result, module') where

33

4−import Control.Monad (foldM)

4+import Prelude hiding (init)

5+import Control.Monad (foldM, when)

56import qualified Data.Map as Map

7+import qualified Data.Maybe as Maybe

68import qualified Data.Set as Set

79import qualified Data.Foldable as F

810import qualified Data.Traversable as T

911

1012import AST.Expression.General as Expr

13+import qualified AST.Effects as Effects

1114import qualified AST.Expression.Source as Source

1215import qualified AST.Expression.Valid as Valid

1316import qualified AST.Declaration as D

17+import qualified AST.Module as Module

18+import qualified AST.Module.Name as ModuleName

1419import qualified AST.Pattern as Pattern

1520import qualified AST.Type as Type

21+import qualified Elm.Compiler.Imports as Imports

22+import qualified Elm.Package as Package

1623import Elm.Utils ((|>))

1724import qualified Reporting.Annotation as A

1825import qualified Reporting.Error.Syntax as Error

@@ -20,163 +27,401 @@ import qualified Reporting.Region as R

2027import qualified Reporting.Result as Result

2128

2229

23−-- VALIDATE DECLARATIONS

2430

25−declarations

26− :: Bool

27− -> [D.SourceDecl]

28− -> Result.Result wrn Error.Error [D.ValidDecl]

29−declarations isRoot sourceDecls =

30− do validDecls <- validateDecls Nothing sourceDecls

31− (\_ _ -> validDecls)

32− <$> declDuplicates validDecls

33− <*> T.traverse (checkDecl isRoot) validDecls

34−

35−

36−validateDecls

37− :: Maybe String

38− -> [D.SourceDecl]

39− -> Result.Result wrn Error.Error [D.ValidDecl]

40−validateDecls maybeComment sourceDecls =

41− case sourceDecls of

31+type Result warning a =

32+ Result.Result () warning Error.Error a

33+

34+

35+

36+-- MODULES

37+

38+

39+module' :: Module.Source -> Result wrn Module.Valid

40+module' (Module.Module name path info) =

41+ let

42+ (ModuleName.Canonical pkgName _) =

43+ name

44+

45+ (Module.Source tag settings docs exports imports decls) =

46+ info

47+ in

48+ do (ValidStuff ports structure) <- validateDecls decls

49+

50+ validEffects <- validateEffects tag settings ports (D._defs structure)

51+

52+ return $ Module.Module name path $

53+ Module.Valid docs exports (addDefaults pkgName imports) structure validEffects

54+

55+

56+

57+-- IMPORTS

58+

59+

60+addDefaults

61+ :: Package.Name

62+ -> [Module.UserImport]

63+ -> ([Module.DefaultImport], [Module.UserImport])

64+addDefaults pkgName imports =

65+ flip (,) imports $

66+ if pkgName == Package.core then

67+ []

68+

69+ else

70+ Imports.defaults

71+

72+

73+

74+-- EFFECTS

75+

76+

77+validateEffects

78+ :: Module.SourceTag

79+ -> Module.SourceSettings

80+ -> [A.Commented Effects.PortRaw]

81+ -> [A.Commented Valid.Def]

82+ -> Result wrn Effects.Raw

83+validateEffects tag settings@(A.A _ pairs) ports validDefs =

84+ case tag of

85+ Module.Normal ->

86+ do noSettings Error.SettingsOnNormalModule settings

87+ noPorts ports

88+ return Effects.None

89+

90+ Module.Port _ ->

91+ do noSettings Error.SettingsOnPortModule settings

92+ return (Effects.Port ports)

93+

94+ Module.Effect tagRegion ->

95+ let

96+ collectSettings (A.A region setting, userValue) dict =

97+ Map.insertWith (++) setting [(region, userValue)] dict

98+

99+ settingsDict =

100+ foldr collectSettings Map.empty pairs

101+ in

102+ do noPorts ports

103+ managerType <- toManagerType tagRegion settingsDict

104+ (r0, r1, r2) <- checkManager tagRegion managerType validDefs

105+ return (Effects.Manager () (Effects.Info tagRegion r0 r1 r2 managerType))

106+

107+

108+noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()

109+noSettings errorMsg (A.A region settings) =

110+ case settings of

42111 [] ->

43− return []

44−

45− sourceDecl : decls ->

46− case sourceDecl of

47− D.Comment comment ->

48− validateDecls (Just comment) decls

49−

50− D.Decl decl ->

51− validateDeclsHelp maybeComment decl decls

52−

53−

54−validateDeclsHelp

55− :: Maybe String

56− -> A.Located D.SourceDecl'

57− -> [D.SourceDecl]

58− -> Result.Result wrn Error.Error [D.ValidDecl]

59−validateDeclsHelp comment (A.A region decl) decls =

60− let addRest validDecl =

61− (:) (A.A (region, comment) validDecl)

62− <$> validateDecls Nothing decls

112+ Result.ok ()

113+

114+ _ : _ ->

115+ Result.throw region errorMsg

116+

117+

118+noPorts :: [A.Commented Effects.PortRaw] -> Result wrn ()

119+noPorts ports =

120+ case ports of

121+ [] ->

122+ Result.ok ()

123+

124+ _ : _ ->

125+ let

126+ toError (A.A (region, _) (Effects.PortRaw name _)) =

127+ A.A region (Error.UnexpectedPort name)

128+ in

129+ Result.throwMany (map toError ports)

130+

131+

132+toManagerType

133+ :: R.Region

134+ -> Map.Map String [(R.Region, A.Located String)]

135+ -> Result wrn Effects.ManagerType

136+toManagerType tagRegion settingsDict =

137+ let

138+ toErrors name entries =

139+ map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries

140+

141+ errors =

142+ settingsDict

143+ |> Map.delete "command"

144+ |> Map.delete "subscription"

145+ |> Map.mapWithKey toErrors

146+ |> Map.elems

147+ |> concat

63148 in

64− case decl of

65− D.Datatype name tvars ctors ->

66− addRest (D.Datatype name tvars ctors)

149+ do when (not (null errors)) (Result.throwMany errors)

150+ maybeEffects <-

151+ (,) <$> extractOne "command" settingsDict

152+ <*> extractOne "subscription" settingsDict

153+

154+ -- TODO check that cmd and sub types exist?

155+ case maybeEffects of

156+ (Nothing, Nothing) ->

157+ Result.throw tagRegion Error.NoSettingsOnEffectModule

158+

159+ (Just cmd, Nothing) ->

160+ return (Effects.CmdManager cmd)

161+

162+ (Nothing, Just sub) ->

163+ return (Effects.SubManager sub)

164+

165+ (Just cmd, Just sub) ->

166+ return (Effects.FxManager cmd sub)

67167

68− D.TypeAlias name tvars alias ->

69− addRest (D.TypeAlias name tvars alias)

70168

71− D.Fixity assoc prec op ->

72− addRest (D.Fixity assoc prec op)

169+extractOne

170+ :: String

171+ -> Map.Map String [(R.Region, A.Located String)]

172+ -> Result wrn (Maybe (A.Located String))

173+extractOne name settingsDict =

174+ case Map.lookup name settingsDict of

175+ Nothing ->

176+ return Nothing

73177

74− D.Definition def ->

75− defHelp comment def decls

178+ Just [] ->

179+ error "Empty lists should never be added to the dictionary of effect module settings."

76180

77− D.Port port ->

78− portHelp comment region port decls

181+ Just [(_, userType)] ->

182+ return (Just userType)

79183

184+ Just ((region, _) : _) ->

185+ Result.throw region (Error.DuplicateSettingOnEffectModule name)

80186

81−-- VALIDATE DEFINITIONS IN DECLARATIONS

82187

83−defHelp

84− :: Maybe String

85− -> Source.Def

86− -> [D.SourceDecl]

87− -> Result.Result wrn Error.Error [D.ValidDecl]

88−defHelp comment (A.A region def) decls =

89− let addRest def' rest =

90− (:) (A.A (region, comment) (D.Definition def'))

91− <$> validateDecls Nothing rest

188+

189+-- CHECK EFFECT MANAGER

190+

191+

192+checkManager

193+ :: R.Region

194+ -> Effects.ManagerType

195+ -> [A.Commented Valid.Def]

196+ -> Result wrn (R.Region, R.Region, R.Region)

197+checkManager tagRegion managerType validDefs =

198+ let

199+ regionDict =

200+ Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)

92201 in

93− case def of

94− Source.Definition pat expr ->

95− do expr' <- expression expr

96− let def' = Valid.Definition pat expr' Nothing

97− checkDefinition def'

98− addRest def' decls

99−

100− Source.TypeAnnotation name tipe ->

101− case decls of

102− D.Decl (A.A _ (D.Definition (A.A _

103− (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest

104− | name == name' ->

105− do expr' <- expression expr

106− let def' = Valid.Definition pat expr' (Just tipe)

107− checkDefinition def'

108− addRest def' rest

202+ const (,,)

203+ <$> requireMaps tagRegion regionDict managerType

204+ <*> requireRegion tagRegion regionDict "init"

205+ <*> requireRegion tagRegion regionDict "onEffects"

206+ <*> requireRegion tagRegion regionDict "onSelfMsg"

109207

110− _ ->

111− Result.throw region (Error.TypeWithoutDefinition name)

112208

209+getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)

210+getSimpleDefRegion decl =

211+ case decl of

212+ A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->

213+ Just (name, region)

214+

215+ _ ->

216+ Nothing

113217

114−-- VALIDATE PORTS IN DECLARATIONS

115218

116−portHelp

117− :: Maybe String

118− -> R.Region

119− -> D.SourcePort

120− -> [D.SourceDecl]

121− -> Result.Result wrn Error.Error [D.ValidDecl]

122−portHelp comment region port decls =

123− let addRest port' rest =

124− (:) (A.A (region,comment) (D.Port port'))

125− <$> validateDecls Nothing rest

219+requireMaps

220+ :: R.Region

221+ -> Map.Map String R.Region

222+ -> Effects.ManagerType

223+ -> Result wrn ()

224+requireMaps tagRegion regionDict managerType =

225+ let

226+ check name =

227+ when (Map.notMember name regionDict) $

228+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)

126229 in

127− case port of

128− D.PortDefinition name _ ->

129− Result.throw region (Error.PortWithoutAnnotation name)

130−

131− D.PortAnnotation name tipe ->

132− case decls of

133− D.Decl (A.A _ (D.Port (D.PortDefinition name' expr))) : rest

134− | name == name' ->

135− do expr' <- expression expr

136− let port' = D.Out name expr' tipe

137− addRest port' rest

230+ case managerType of

231+ Effects.CmdManager _ ->

232+ check "cmdMap"

233+

234+ Effects.SubManager _ ->

235+ check "subMap"

236+

237+ Effects.FxManager _ _ ->

238+ check "cmdMap" <* check "subMap"

239+

240+

241+requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region

242+requireRegion tagRegion regionDict name =

243+ case Map.lookup name regionDict of

244+ Just region ->

245+ return region

246+

247+ Nothing ->

248+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)

249+

250+

251+

252+-- COLLAPSE COMMENTS

253+

254+

255+collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]

256+collapseComments listWithComments =

257+ case listWithComments of

258+ [] ->

259+ Result.ok []

260+

261+ D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->

262+ let

263+ entry =

264+ A.A (region, Just msg) a

265+ in

266+ fmap (entry:) (collapseComments rest)

267+

268+ D.Comment (A.A region _) : rest ->

269+ collapseComments rest

270+ <* Result.throw region Error.CommentOnNothing

271+

272+

273+ D.Whatever (A.A region a) : rest ->

274+ let

275+ entry =

276+ A.A (region, Nothing) a

277+ in

278+ fmap (entry:) (collapseComments rest)

279+

280+

281+

282+-- VALIDATE STRUCTURED SOURCE

283+

284+

285+validateDecls :: [D.Source] -> Result wrn ValidStuff

286+validateDecls sourceDecls =

287+ do rawDecls <- collapseComments sourceDecls

288+

289+ validStuff <- validateRawDecls rawDecls

290+

291+ let (D.Decls _ unions aliases _) = _structure validStuff

292+

293+ return validStuff

294+ <* F.traverse_ checkTypeVarsInUnion unions

295+ <* F.traverse_ checkTypeVarsInAlias aliases

296+ <* checkDuplicates validStuff

297+

298+

299+

300+-- VALIDATE DECLARATIONS

301+

302+

303+data ValidStuff =

304+ ValidStuff

305+ { _ports :: [A.Commented Effects.PortRaw]

306+ , _structure :: D.Valid

307+ }

308+

309+

310+validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff

311+validateRawDecls commentedDecls =

312+ vrdHelp commentedDecls [] (D.Decls [] [] [] [])

313+

314+

315+vrdHelp

316+ :: [A.Commented D.Raw]

317+ -> [A.Commented Effects.PortRaw]

318+ -> D.Valid

319+ -> Result wrn ValidStuff

320+vrdHelp commentedDecls ports structure =

321+ case commentedDecls of

322+ [] ->

323+ Result.ok (ValidStuff ports structure)

324+

325+ A.A ann decl : rest ->

326+ case decl of

327+ D.Union (D.Type name tvars ctors) ->

328+ vrdHelp rest ports (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)

329+

330+ D.Alias (D.Type name tvars alias) ->

331+ vrdHelp rest ports (D.addAlias (A.A ann (D.Type name tvars alias)) structure)

332+

333+ D.Fixity fixity ->

334+ vrdHelp rest ports (D.addInfix fixity structure)

335+

336+ D.Def (A.A region def) ->

337+ vrdDefHelp rest (A.A (region, snd ann) def) ports structure

338+

339+ D.Port name tipe ->

340+ vrdHelp rest (A.A ann (Effects.PortRaw name tipe) : ports) structure

341+

342+

343+vrdDefHelp

344+ :: [A.Commented D.Raw]

345+ -> A.Commented Source.Def'

346+ -> [A.Commented Effects.PortRaw]

347+ -> D.Valid

348+ -> Result wrn ValidStuff

349+vrdDefHelp remainingDecls (A.A ann def) ports structure =

350+ let

351+ addDef validDef (ValidStuff finalPorts struct) =

352+ ValidStuff finalPorts (D.addDef (A.A ann validDef) struct)

353+ in

354+ case def of

355+ Source.Definition pat expr ->

356+ addDef

357+ <$> validateDef pat expr Nothing

358+ <*> vrdHelp remainingDecls ports structure

359+

360+ Source.Annotation name tipe ->

361+ case remainingDecls of

362+ A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest

363+ | Pattern.isVar name pat ->

364+ addDef

365+ <$> validateDef pat expr (Just tipe)

366+ <*> vrdHelp rest ports structure

138367

139368 _ ->

140− addRest (D.In name tipe) decls

369+ vrdHelp remainingDecls ports structure

370+ <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)

371+

141372

142373

143374-- VALIDATE DEFINITIONS

144375

145−definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

376+

377+definitions :: [Source.Def] -> Result wrn [Valid.Def]

146378definitions sourceDefs =

147379 do validDefs <- definitionsHelp sourceDefs

148− let patterns = map (\(Valid.Definition p _ _) -> p) validDefs

149− defDuplicates patterns

380+

381+ validDefs

382+ |> map Valid.getPattern

383+ |> concatMap Pattern.boundVars

384+ |> detectDuplicates Error.DuplicateDefinition

385+

150386 return validDefs

151387

152388

153−definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

389+definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]

154390definitionsHelp sourceDefs =

155391 case sourceDefs of

156392 [] ->

157− return []

393+ return []

158394

159395 A.A _ (Source.Definition pat expr) : rest ->

160− do expr' <- expression expr

161− let def = Valid.Definition pat expr' Nothing

162− checkDefinition def

163− (:) def <$> definitionsHelp rest

164−

165− A.A region (Source.TypeAnnotation name tipe) : rest ->

166− case rest of

167− A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'

168− | name == name' ->

169− do expr' <- expression expr

170− let def = Valid.Definition pat expr' (Just tipe)

171− checkDefinition def

172− (:) def <$> definitionsHelp rest'

173−

174− _ ->

175− Result.throw region (Error.TypeWithoutDefinition name)

176−

177−

178−checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()

179−checkDefinition (Valid.Definition pattern body _) =

396+ (:)

397+ <$> validateDef pat expr Nothing

398+ <*> definitionsHelp rest

399+

400+ A.A region (Source.Annotation name tipe) : rest ->

401+ case rest of

402+ A.A _ (Source.Definition pat expr) : rest'

403+ | Pattern.isVar name pat ->

404+ (:)

405+ <$> validateDef pat expr (Just tipe)

406+ <*> definitionsHelp rest'

407+

408+ _ ->

409+ Result.throw region (Error.TypeWithoutDefinition name)

410+

411+

412+validateDef

413+ :: Pattern.Raw

414+ -> Source.Expr

415+ -> Maybe Type.Raw

416+ -> Result wrn Valid.Def

417+validateDef pat expr maybeType =

418+ do validExpr <- expression expr

419+ validateDefPattern pat validExpr

420+ return $ Valid.Def pat validExpr maybeType

421+

422+

423+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()

424+validateDefPattern pattern body =

180425 case fst (Expr.collectLambdas body) of

181426 [] ->

182427 return ()

@@ -194,9 +439,11 @@ checkDefinition (Valid.Definition pattern body _) =

194439 Result.throw (R.merge start end) (Error.BadFunctionName (length args))

195440

196441

442+

197443-- VALIDATE EXPRESSIONS

198444

199−expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr

445+

446+expression :: Source.Expr -> Result wrn Valid.Expr

200447expression (A.A ann sourceExpression) =

201448 A.A ann <$>

202449 case sourceExpression of

@@ -270,162 +517,144 @@ expression (A.A ann sourceExpression) =

270517 <$> definitions defs

271518 <*> expression body

272519

273− GLShader uid src gltipe ->

274− return (GLShader uid src gltipe)

520+ Cmd moduleName ->

521+ return (Cmd moduleName)

275522

276− Port impl ->

277− Port <$>

278− case impl of

279− In name tipe ->

280− return (In name tipe)

523+ Sub moduleName ->

524+ return (Sub moduleName)

281525

282− Out name expr tipe ->

283− do expr' <- expression expr

284− return (Out name expr' tipe)

526+ OutgoingPort name tipe ->

527+ return (OutgoingPort name tipe)

285528

286− Task name expr tipe ->

287− do expr' <- expression expr

288− return (Task name expr' tipe)

529+ IncomingPort name tipe ->

530+ return (IncomingPort name tipe)

289531

532+ Program _ _ ->

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

290534

291−second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

535+ SaveEnv moduleName effects ->

536+ return (SaveEnv moduleName effects)

537+

538+ GLShader uid src gltipe ->

539+ return (GLShader uid src gltipe)

540+

541+

542+second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)

292543second (value, expr) =

293544 (,) value <$> expression expr

294545

295546

296−both

297− :: (Source.Expr, Source.Expr)

298− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)

547+both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)

299548both (expr1, expr2) =

300549 (,) <$> expression expr1 <*> expression expr2

301550

302551

552+

303553-- VALIDATE PATTERNS

304554

305−validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern

555+

556+validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw

306557validatePattern pattern =

307558 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)

308559 return pattern

309560

310561

311−-- DETECT DUPLICATES

312562

313−detectDuplicates

314− :: (String -> Error.Error)

315− -> [A.Located String]

316− -> Result.Result wrn Error.Error ()

317−detectDuplicates tag names =

318− let add (A.A region name) dict =

319− Map.insertWith (++) name [region] dict

563+-- DETECT DUPLICATES

320564

321− makeGroups pairs =

322− Map.toList (foldr add Map.empty pairs)

323565

324− check (name, regions) =

325− case regions of

326− _ : region : _ ->

327− Result.throw region (tag name)

566+checkDuplicates :: ValidStuff -> Result wrn ()

567+checkDuplicates (ValidStuff ports (D.Decls defs unions aliases _)) =

568+ let

569+ -- SIMPLE NAMES

328570

329− _ ->

330− return ()

331− in

332− F.traverse_ check (makeGroups names)

571+ defValues =

572+ concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs

333573

574+ portValues =

575+ map fromPort ports

334576

335−defDuplicates

336− :: [Pattern.RawPattern]

337− -> Result.Result wrn Error.Error ()

338−defDuplicates patterns =

339− concatMap Pattern.boundVars patterns

340− |> detectDuplicates Error.DuplicateDefinition

577+ fromPort (A.A (region, _) (Effects.PortRaw name _)) =

578+ A.A region name

341579

580+ -- TYPE NAMES

342581

343−declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()

344−declDuplicates decls =

345− let (valueLists, typeLists) = unzip (map extractValues decls)

346− in

347− (\_ _ -> ())

348− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)

349− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)

582+ (types, typeValues) =

583+ unzip (map fromUnion unions ++ map fromAlias aliases)

350584

585+ fromUnion (A.A (region, _) (D.Type name _ ctors)) =

586+ ( A.A region name

587+ , map (A.A region . fst) ctors

588+ )

351589

352−extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])

353−extractValues (A.A (region, _) decl) =

354− case decl of

355− D.Definition (Valid.Definition pattern _ _) ->

356− ( Pattern.boundVars pattern

357− , []

358− )

590+ fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =

591+ (,) (A.A region name) $

592+ case tipe of

593+ Type.RRecord _ _ ->

594+ [A.A region name]

359595

360− D.Datatype name _ ctors ->

361− ( map (A.A region . fst) ctors

362− , [A.A region name]

363− )

596+ _ ->

597+ []

598+ in

599+ F.sequenceA_

600+ [ detectDuplicates Error.DuplicateValueDeclaration (portValues ++ defValues)

601+ , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)

602+ , detectDuplicates Error.DuplicateTypeDeclaration types

603+ ]

364604

365− D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->

366− ( [A.A region name]

367− , [A.A region name]

368− )

369605

370− D.TypeAlias name _ _ ->

371− ( []

372− , [A.A region name]

373− )

606+detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()

607+detectDuplicates tag names =

608+ let

609+ add (A.A region name) dict =

610+ Map.insertWith (++) name [region] dict

374611

375− D.Port port ->

376− ( [A.A region (D.validPortName port)]

377− , []

378− )

612+ makeGroups pairs =

613+ Map.toList (foldr add Map.empty pairs)

379614

380− D.Fixity _ _ _ ->

381− ( []

382− , []

383− )

615+ check (name, regions) =

616+ case regions of

617+ _ : region : _ ->

618+ Result.throw region (tag name)

384619

620+ _ ->

621+ return ()

622+ in

623+ F.traverse_ check (makeGroups names)

385624

386−-- UNBOUND TYPE VARIABLES

387625

388−checkDecl :: Bool -> D.ValidDecl -> Result.Result wrn Error.Error ()

389−checkDecl isRoot (A.A (region,_) decl) =

390− case decl of

391− D.Definition _ ->

392− return ()

393626

394− D.Datatype name boundVars ctors ->

395− case diff boundVars (concatMap freeVars (concatMap snd ctors)) of

396− (_, []) ->

397− return ()

627+-- UNBOUND TYPE VARIABLES

398628

399− (_, unbound) ->

400− Result.throw region

401− (Error.UnboundTypeVarsInUnion name boundVars unbound)

402629

403− D.TypeAlias name boundVars tipe ->

404− case diff boundVars (freeVars tipe) of

405− ([], []) ->

406− return ()

630+checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()

631+checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =

632+ case diff boundVars (concatMap freeVars (concatMap snd ctors)) of

633+ (_, []) ->

634+ return ()

407635

408− ([], unbound) ->

409− Result.throw region

410− (Error.UnboundTypeVarsInAlias name boundVars unbound)

636+ (_, unbound) ->

637+ Result.throw region

638+ (Error.UnboundTypeVarsInUnion name boundVars unbound)

411639

412− (unused, []) ->

413− Result.throw region

414− (Error.UnusedTypeVarsInAlias name boundVars unused)

415640

416− (unused, unbound) ->

417− Result.throw region

418− (Error.MessyTypeVarsInAlias name boundVars unused unbound)

641+checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()

642+checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =

643+ case diff boundVars (freeVars tipe) of

644+ ([], []) ->

645+ return ()

419646

420− D.Port _ ->

421− if isRoot then

422− return ()

647+ ([], unbound) ->

648+ Result.throw region

649+ (Error.UnboundTypeVarsInAlias name boundVars unbound)

423650

424− else

425− Result.throw region Error.UnexpectedPort

651+ (unused, []) ->

652+ Result.throw region

653+ (Error.UnusedTypeVarsInAlias name boundVars unused)

426654

427− D.Fixity _ _ _ ->

428− return ()

655+ (unused, unbound) ->

656+ Result.throw region

657+ (Error.MessyTypeVarsInAlias name boundVars unused unbound)

429658

430659

431660diff :: [String] -> [A.Located String] -> ([String], [String])

@@ -442,23 +671,21 @@ diff left right =

442671 )

443672

444673

445−

446674freeVars :: Type.Raw -> [A.Located String]

447675freeVars (A.A region tipe) =

448− case tipe of

449− Type.RLambda t1 t2 ->

450− freeVars t1 ++ freeVars t2

451−

452− Type.RVar x ->

453− [A.A region x]

676+ case tipe of

677+ Type.RLambda t1 t2 ->

678+ freeVars t1 ++ freeVars t2

454679

455− Type.RType _ ->

456− []

680+ Type.RVar x ->

681+ [A.A region x]

457682

458− Type.RApp t ts ->

459− concatMap freeVars (t:ts)

683+ Type.RType _ ->

684+ []

460685

461− Type.RRecord fields ext ->

462− maybe [] freeVars ext

463− ++ concatMap (freeVars . snd) fields

686+ Type.RApp t ts ->

687+ concatMap freeVars (t:ts)

464688

689+ Type.RRecord fields ext ->

690+ maybe [] freeVars ext

691+ ++ concatMap (freeVars . snd) fields

tests/Test/Compiler.hs+14−12

@@ -4,6 +4,8 @@ module Test.Compiler (compilerTests) where

44

55import Control.Exception (try, IOException)

66

7+import qualified Data.Text.Lazy as Text

8+import qualified Data.Text.Lazy.IO as Text

79import qualified Data.Map as Map

810import Data.Maybe (isJust)

911

@@ -86,15 +88,15 @@ essentialInterfaces =

8688

8789buildCoreInterface :: [(String, Type.Canonical)] -> Module.Interface

8890buildCoreInterface members =

89− let exports = map (Variable.Value . fst) members

90− imports = []

91− types = Map.fromList members

92− adts = Map.empty

93− aliases = Map.empty

94− fixities = []

95− ports = []

91+ let

92+ exports = map (Variable.Value . fst) members

93+ imports = []

94+ types = Map.fromList members

95+ adts = Map.empty

96+ aliases = Map.empty

97+ fixities = []

9698 in

97− Module.Interface Compiler.version Package.coreName exports types imports adts aliases fixities ports

99+ Module.Interface Compiler.version Package.core exports imports types adts aliases fixities

98100

99101

100102compileString :: FilePath -> String -> Either String Compiler.Result

@@ -102,7 +104,7 @@ compileString filePath source =

102104 let dependentModuleNames =

103105 Map.keys essentialInterfaces

104106 context =

105− Compiler.Context Package.coreName True False dependentModuleNames

107+ Compiler.Context Package.core False dependentModuleNames

106108 (dealiaser, _warnings, result) =

107109 Compiler.compile context source essentialInterfaces

108110 formatErrors errors =

@@ -162,8 +164,8 @@ doWriteNewExpectedTest expectedJsDir filePath =

162164 -- Force the evaluation of `js` before `writeFile`

163165 -- so that if an error is raised we do not unintentionally write an empty file.

164166 -- NB: `js` can be an empty string in the case of NoExpressions.elm

165− assertBool "" (length js >= 0)

166− writeFile expectedFilePath js

167+ assertBool "" (Text.length js >= 0)

168+ Text.writeFile expectedFilePath js

167169 assertFailure ("Wrote new expected js: " ++ expectedFilePath)

168170

169171 _ ->

@@ -210,7 +212,7 @@ matchesExpected :: String -> Either String Compiler.Result -> Assertion

210212matchesExpected expectedJs result =

211213 case result of

212214 Right (Compiler.Result _ _ js) ->

213− assertEqual matchFailureMessage expectedJs js

215+ assertEqual matchFailureMessage (Text.pack expectedJs) js

214216

215217 Left errorMessages ->

216218 assertFailure $ "Compile failed:\n" ++ errorMessages

tests/test-files/good-expected-js/Cases/CharCase.elm.js+8−10

@@ -1,10 +1,8 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var foo = function (x) { var _p0 = x;if (_p0.valueOf() === "A") { return "hello";} else { return "letter A was not seen";}};

9− return _elm.Main.values = {_op: _op,foo: foo};

10−};

1+var _elm_lang$core$Main$foo = function (x) {

2+ var _p0 = x;

3+ if (_p0.valueOf() === 'A') {

4+ return 'hello';

5+ } else {

6+ return 'letter A was not seen';

7+ }

8+};

tests/test-files/good-expected-js/Cases/ListZip.elm.js+21−23

@@ -1,23 +1,21 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var Cons = F2(function (a,b) { return {ctor: "Cons",_0: a,_1: b};});

9− var Nil = {ctor: "Nil"};

10− var zip = F2(function (list1,list2) {

11− var _p0 = {ctor: "_Tuple2",_0: list1,_1: list2};

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

13− return Nil;

14− } else {

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

16− return Nil;

17− } else {

18− return A2(Cons,{ctor: "_Tuple2",_0: _p0._0._0,_1: _p0._1._0},A2(zip,_p0._0._1,_p0._1._1));

19− }

20− }

21− });

22− return _elm.Main.values = {_op: _op,Nil: Nil,Cons: Cons,zip: zip};

23−};

1+var _elm_lang$core$Main$Cons = F2(

2+ function (a, b) {

3+ return {ctor: 'Cons', _0: a, _1: b};

4+ });

5+var _elm_lang$core$Main$Nil = {ctor: 'Nil'};

6+var _elm_lang$core$Main$zip = F2(

7+ function (list1, list2) {

8+ var _p0 = {ctor: '_Tuple2', _0: list1, _1: list2};

9+ if (_p0._0.ctor === 'Nil') {

10+ return _elm_lang$core$Main$Nil;

11+ } else {

12+ if (_p0._1.ctor === 'Nil') {

13+ return _elm_lang$core$Main$Nil;

14+ } else {

15+ return A2(

16+ _elm_lang$core$Main$Cons,

17+ {ctor: '_Tuple2', _0: _p0._0._0, _1: _p0._1._0},

18+ A2(_elm_lang$core$Main$zip, _p0._0._1, _p0._1._1));

19+ }

20+ }

21+ });

tests/test-files/good-expected-js/CodeGenBugs/CommentInterpretedAsInfix.elm.js+13−12

@@ -1,12 +1,13 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var always = F2(function (x,s) { return x;});

9− _op["|>"] = F2(function (a,f) { return f(a);});

10− var value = A2(_op["|>"],"Hi",always("Hello"));

11− return _elm.Main.values = {_op: _op,always: always,value: value};

12−};

1+var _elm_lang$core$Main$always = F2(

2+ function (x, s) {

3+ return x;

4+ });

5+var _elm_lang$core$Main_ops = _elm_lang$core$Main_ops || {};

6+_elm_lang$core$Main_ops['|>'] = F2(

7+ function (a, f) {

8+ return f(a);

9+ });

10+var _elm_lang$core$Main$value = A2(

11+ _elm_lang$core$Main_ops['|>'],

12+ 'Hi',

13+ _elm_lang$core$Main$always('Hello'));

tests/test-files/good-expected-js/CodeGenBugs/NestedPatternMatch.elm.js+4−10

@@ -1,10 +1,4 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var foo = function (_p0) { var _p1 = _p0;return _p1;};

9− return _elm.Main.values = {_op: _op,foo: foo};

10−};

1+var _elm_lang$core$Main$foo = function (_p0) {

2+ var _p1 = _p0;

3+ return _p1;

4+};

tests/test-files/good-expected-js/CodeGenBugs/Shadowing.elm.js+16−15

@@ -1,15 +1,16 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var toName = function (a) {

9− var name = function () { var _p0 = a;if (_p0.ctor === "First") { return "True";} else { return _p0._0;}}();

10− return name;

11− };

12− var Second = F2(function (a,b) { return {ctor: "Second",_0: a,_1: b};});

13− var First = {ctor: "First"};

14− return _elm.Main.values = {_op: _op,First: First,Second: Second,toName: toName};

15−};

1+var _elm_lang$core$Main$toName = function (a) {

2+ var name = function () {

3+ var _p0 = a;

4+ if (_p0.ctor === 'First') {

5+ return 'True';

6+ } else {

7+ return _p0._0;

8+ }

9+ }();

10+ return name;

11+};

12+var _elm_lang$core$Main$Second = F2(

13+ function (a, b) {

14+ return {ctor: 'Second', _0: a, _1: b};

15+ });

16+var _elm_lang$core$Main$First = {ctor: 'First'};

tests/test-files/good-expected-js/CodeGenBugs/Shadowing2.elm.js+13−20

@@ -1,20 +1,13 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var Nothing = {ctor: "Nothing"};

9− var Just = function (a) { return {ctor: "Just",_0: a};};

10− var withDefault0 = function (maybe) {

11− var _p0 = maybe;

12− if (_p0.ctor === "Just") {

13− var maybe = Just("shadow argument, but do not overwrite it in JS!");

14− return _p0._0;

15− } else {

16− return 0;

17− }

18− };

19− return _elm.Main.values = {_op: _op,Just: Just,Nothing: Nothing,withDefault0: withDefault0};

20−};

1+var _elm_lang$core$Main$Nothing = {ctor: 'Nothing'};

2+var _elm_lang$core$Main$Just = function (a) {

3+ return {ctor: 'Just', _0: a};

4+};

5+var _elm_lang$core$Main$withDefault0 = function (maybe) {

6+ var _p0 = maybe;

7+ if (_p0.ctor === 'Just') {

8+ var maybe = _elm_lang$core$Main$Just('shadow argument, but do not overwrite it in JS!');

9+ return _p0._0;

10+ } else {

11+ return 0;

12+ }

13+};

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_ListAny.elm.js+20−24

@@ -1,24 +1,20 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var any = F2(function (isOk,list) {

9− any: while (true) {

10− var _p0 = list;

11− if (_p0.ctor === "::") {

12− if (isOk(_p0._0)) return true; else {

13− var _v1 = isOk,_v2 = _p0._1;

14− isOk = _v1;

15− list = _v2;

16− continue any;

17− }

18− } else {

19− return false;

20− }

21− }

22− });

23− return _elm.Main.values = {_op: _op,any: any};

24−};

1+var _elm_lang$core$Main$any = F2(

2+ function (isOk, list) {

3+ any:

4+ while (true) {

5+ var _p0 = list;

6+ if (_p0.ctor === '::') {

7+ if (isOk(_p0._0)) {

8+ return true;

9+ } else {

10+ var _v1 = isOk,

11+ _v2 = _p0._1;

12+ isOk = _v1;

13+ list = _v2;

14+ continue any;

15+ }

16+ } else {

17+ return false;

18+ }

19+ }

20+ });

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_NameNormalization.elm.js+12−10

@@ -1,10 +1,12 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var go = function (n$) { go: while (true) if (n$) { var _v0 = n$;n$ = _v0;continue go;} else return false;};

9− return _elm.Main.values = {_op: _op,go: go};

10−};

1+var _elm_lang$core$Main$go = function (n$) {

2+ go:

3+ while (true) {

4+ if (n$) {

5+ var _v0 = n$;

6+ n$ = _v0;

7+ continue go;

8+ } else {

9+ return false;

10+ }

11+ }

12+};

tests/test-files/good-expected-js/CodeGenBugs/TailRecursion_UnsafeLabel.elm.js+23−25

@@ -1,25 +1,23 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var foldl$ = F3(function (update,state,items) {

9− foldl$: while (true) {

10− var _p0 = items;

11− if (_p0.ctor === "Nil") {

12− return state;

13− } else {

14− var _v1 = update,_v2 = A2(update,_p0._0,state),_v3 = _p0._1;

15− update = _v1;

16− state = _v2;

17− items = _v3;

18− continue foldl$;

19− }

20− }

21− });

22− var Cons = F2(function (a,b) { return {ctor: "Cons",_0: a,_1: b};});

23− var Nil = {ctor: "Nil"};

24− return _elm.Main.values = {_op: _op,Nil: Nil,Cons: Cons,foldl$: foldl$};

25−};

1+var _elm_lang$core$Main$foldl$ = F3(

2+ function (update, state, items) {

3+ foldl$:

4+ while (true) {

5+ var _p0 = items;

6+ if (_p0.ctor === 'Nil') {

7+ return state;

8+ } else {

9+ var _v1 = update,

10+ _v2 = A2(update, _p0._0, state),

11+ _v3 = _p0._1;

12+ update = _v1;

13+ state = _v2;

14+ items = _v3;

15+ continue foldl$;

16+ }

17+ }

18+ });

19+var _elm_lang$core$Main$Cons = F2(

20+ function (a, b) {

21+ return {ctor: 'Cons', _0: a, _1: b};

22+ });

23+var _elm_lang$core$Main$Nil = {ctor: 'Nil'};

tests/test-files/good-expected-js/Crash/CrashCase.elm.js+14−17

@@ -1,17 +1,14 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm),$Debug = Elm.Debug.make(_elm);

7− var _op = {};

8− var test = function (x) {

9− var _p0 = x;

10− if (_p0 === 1) {

11− return 2;

12− } else {

13− return _U.crashCase("Main",{start: {line: 5,column: 5},end: {line: 9,column: 43}},_p0)("unexpected value");

14− }

15− };

16− return _elm.Main.values = {_op: _op,test: test};

17−};

1+var _elm_lang$core$Main$test = function (x) {

2+ var _p0 = x;

3+ if (_p0 === 1) {

4+ return 2;

5+ } else {

6+ return _elm_lang$core$Native_Utils.crashCase(

7+ 'Main',

8+ {

9+ start: {line: 5, column: 5},

10+ end: {line: 9, column: 43}

11+ },

12+ _p0)('unexpected value');

13+ }

14+};

tests/test-files/good-expected-js/Crash/CrashIf.elm.js+8−10

@@ -1,10 +1,8 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm),$Debug = Elm.Debug.make(_elm);

7− var _op = {};

8− var test = function (x) { return x ? 2 : _U.crash("Main",{start: {line: 8,column: 9},end: {line: 8,column: 20}})("unexpected value");};

9− return _elm.Main.values = {_op: _op,test: test};

10−};

1+var _elm_lang$core$Main$test = function (x) {

2+ return x ? 2 : _elm_lang$core$Native_Utils.crash(

3+ 'Main',

4+ {

5+ start: {line: 8, column: 9},

6+ end: {line: 8, column: 20}

7+ })('unexpected value');

8+};

tests/test-files/good-expected-js/Declarations/NoDefinitions.elm.js−9

@@ -1,9 +0,0 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− return _elm.Main.values = {_op: _op};

9−};

tests/test-files/good-expected-js/Declarations/Ports.elm.jsdeleted−49

@@ -1,49 +0,0 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var students = Elm.Native.Port.make(_elm).outbound("students",

9− function (v) {

10− return Elm.Native.List.make(_elm).toArray(v).map(function (v) { return {name: v.name,age: v.age};});

11− },

12− _U.list([{name: "Tom",age: 42}]));

13− var time = Elm.Native.Port.make(_elm).outbound("time",function (v) { return v;},3.14);

14− var fortyTwo = Elm.Native.Port.make(_elm).outbound("fortyTwo",function (v) { return v;},42);

15− var record = Elm.Native.Port.make(_elm).inbound("record",

16− "{ x : Float, y : Float }",

17− function (v) {

18− return typeof v === "object" && "x" in v && "y" in v ? {_: {}

19− ,x: typeof v.x === "number" ? v.x : _U.badPort("a number",v.x)

20− ,y: typeof v.y === "number" ? v.y : _U.badPort("a number",

21− v.y)} : _U.badPort("an object with fields `x`, `y`",v);

22− });

23− var array = Elm.Native.Port.make(_elm).inbound("array",

24− "List Float",

25− function (v) {

26− return typeof v === "object" && v instanceof Array ? Elm.Native.List.make(_elm).fromArray(v.map(function (v) {

27− return typeof v === "number" ? v : _U.badPort("a number",v);

28− })) : _U.badPort("an array",v);

29− });

30− var tuple = Elm.Native.Port.make(_elm).inbound("tuple",

31− "( Float, Bool )",

32− function (v) {

33− return typeof v === "object" && v instanceof Array ? {ctor: "_Tuple2"

34− ,_0: typeof v[0] === "number" ? v[0] : _U.badPort("a number",v[0])

35− ,_1: typeof v[1] === "boolean" ? v[1] : _U.badPort("a boolean (true or false)",

36− v[1])} : _U.badPort("an array",v);

37− });

38− var number = Elm.Native.Port.make(_elm).inbound("number",

39− "Int",

40− function (v) {

41− return typeof v === "number" && isFinite(v) && Math.floor(v) === v ? v : _U.badPort("an integer",v);

42− });

43− var userID = Elm.Native.Port.make(_elm).inbound("userID",

44− "String",

45− function (v) {

46− return typeof v === "string" || typeof v === "object" && v instanceof String ? v : _U.badPort("a string",v);

47− });

48− return _elm.Main.values = {_op: _op};

49−};

tests/test-files/good-expected-js/Declarations/PortsWithTypeAliases.elm.jsdeleted−27

@@ -1,27 +0,0 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var pairs = Elm.Native.Port.make(_elm).inbound("pairs",

9− "Main.Point String String",

10− function (v) {

11− return typeof v === "object" && "x" in v && "y" in v ? {_: {}

12− ,x: typeof v.x === "string" || typeof v.x === "object" && v.x instanceof String ? v.x : _U.badPort("a string",

13− v.x)

14− ,y: typeof v.y === "string" || typeof v.y === "object" && v.y instanceof String ? v.y : _U.badPort("a string",

15− v.y)} : _U.badPort("an object with fields `x`, `y`",v);

16− });

17− var points = Elm.Native.Port.make(_elm).inbound("points",

18− "Main.Point2D",

19− function (v) {

20− return typeof v === "object" && "x" in v && "y" in v ? {_: {}

21− ,x: typeof v.x === "number" ? v.x : _U.badPort("a number",v.x)

22− ,y: typeof v.y === "number" ? v.y : _U.badPort("a number",

23− v.y)} : _U.badPort("an object with fields `x`, `y`",v);

24− });

25− var Point = F2(function (a,b) { return {x: a,y: b};});

26− return _elm.Main.values = {_op: _op,Point: Point};

27−};

tests/test-files/good-expected-js/Lists/EmptyList.elm.js+2−10

@@ -1,10 +1,2 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var emptyList = _U.list([]);

9− return _elm.Main.values = {_op: _op,emptyList: emptyList};

10−};

1+var _elm_lang$core$Main$emptyList = _elm_lang$core$Native_List.fromArray(

2+ []);

tests/test-files/good-expected-js/Lists/ListRange.elm.js+1−10

@@ -1,10 +1 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var listRange = _U.range(2,10);

9− return _elm.Main.values = {_op: _op,listRange: listRange};

10−};

1+var _elm_lang$core$Main$listRange = _elm_lang$core$Native_List.range(2, 10);

tests/test-files/good-expected-js/Lists/NonEmptyList.elm.js+2−10

@@ -1,10 +1,2 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var nonEmptyList = _U.list([1,4,5]);

9− return _elm.Main.values = {_op: _op,nonEmptyList: nonEmptyList};

10−};

1+var _elm_lang$core$Main$nonEmptyList = _elm_lang$core$Native_List.fromArray(

2+ [1, 4, 5]);

tests/test-files/good-expected-js/Records/AliasSubstitution.elm.js+3−10

@@ -1,10 +1,3 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var extractVec = function (v) { return {x: v.x,y: v.y};};

9− return _elm.Main.values = {_op: _op,extractVec: extractVec};

10−};

1+var _elm_lang$core$Main$extractVec = function (v) {

2+ return {x: v.x, y: v.y};

3+};

tests/test-files/good-expected-js/Records/NonHomogeneousRecords.elm.js+9−11

@@ -1,11 +1,9 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var bindFields = function (thing) { var y = thing.y;var x = thing.x;return thing;};

9− var Thing = F2(function (a,b) { return {x: a,y: b};});

10− return _elm.Main.values = {_op: _op,Thing: Thing,bindFields: bindFields};

11−};

1+var _elm_lang$core$Main$bindFields = function (thing) {

2+ var y = thing.y;

3+ var x = thing.x;

4+ return thing;

5+};

6+var _elm_lang$core$Main$Thing = F2(

7+ function (a, b) {

8+ return {x: a, y: b};

9+ });

tests/test-files/good-expected-js/Soundness/Apply.elm.js+6−10

@@ -1,10 +1,6 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var apply = function (f) { var g = function (x) { return f(x);};return g;};

9− return _elm.Main.values = {_op: _op,apply: apply};

10−};

1+var _elm_lang$core$Main$apply = function (f) {

2+ var g = function (x) {

3+ return f(x);

4+ };

5+ return g;

6+};

tests/test-files/good-expected-js/Soundness/ApplyAnnotated.elm.js+6−10

@@ -1,10 +1,6 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var apply = function (f) { var g = function (x) { return f(x);};return g;};

9− return _elm.Main.values = {_op: _op,apply: apply};

10−};

1+var _elm_lang$core$Main$apply = function (f) {

2+ var g = function (x) {

3+ return f(x);

4+ };

5+ return g;

6+};

tests/test-files/good-expected-js/Soundness/Id.elm.js+6−10

@@ -1,10 +1,6 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var myId = function () { var id = function (x) { return x;};return id;}();

9− return _elm.Main.values = {_op: _op,myId: myId};

10−};

1+var _elm_lang$core$Main$myId = function () {

2+ var id = function (x) {

3+ return x;

4+ };

5+ return id;

6+}();

tests/test-files/good-expected-js/Soundness/IdAnnotated.elm.js+6−10

@@ -1,10 +1,6 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var myId = function () { var id = function (x) { return x;};return id;}();

9− return _elm.Main.values = {_op: _op,myId: myId};

10−};

1+var _elm_lang$core$Main$myId = function () {

2+ var id = function (x) {

3+ return x;

4+ };

5+ return id;

6+}();

tests/test-files/good-expected-js/Soundness/SpecificAnnotationInt.elm.js+3−10

@@ -1,10 +1,3 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var px = function (x) { return "test";};

9− return _elm.Main.values = {_op: _op,px: px};

10−};

1+var _elm_lang$core$Main$px = function (x) {

2+ return 'test';

3+};

tests/test-files/good-expected-js/Soundness/SpecificAnnotationNumber.elm.js+3−10

@@ -1,10 +1,3 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var px = function (x) { return "test";};

9− return _elm.Main.values = {_op: _op,px: px};

10−};

1+var _elm_lang$core$Main$px = function (x) {

2+ return 'test';

3+};

tests/test-files/good-expected-js/Soundness/TrickyId.elm.js+4−10

@@ -1,10 +1,4 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var myId = function (x) { var y = x;return y;};

9− return _elm.Main.values = {_op: _op,myId: myId};

10−};

1+var _elm_lang$core$Main$myId = function (x) {

2+ var y = x;

3+ return y;

4+};

tests/test-files/good-expected-js/Soundness/TrickyIdAnnotated.elm.js+4−10

@@ -1,10 +1,4 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var myId = function (x) { var y = x;return y;};

9− return _elm.Main.values = {_op: _op,myId: myId};

10−};

1+var _elm_lang$core$Main$myId = function (x) {

2+ var y = x;

3+ return y;

4+};

tests/test-files/good-expected-js/Strings/Multiline.elm.js+1−10

@@ -1,10 +1 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var s = "\nhere\'s a quote: \"\n\n";

9− return _elm.Main.values = {_op: _op,s: s};

10−};

1+var _elm_lang$core$Main$s = '\nhere\'s a quote: \"\n\n';

tests/test-files/good-expected-js/Strings/MultilineNormal.elm.js+1−10

@@ -1,10 +1 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var s = "\nhere\'s a quote: \"\n\n";

9− return _elm.Main.values = {_op: _op,s: s};

10−};

1+var _elm_lang$core$Main$s = '\nhere\'s a quote: \"\n\n';

tests/test-files/good-expected-js/Strings/QuotesAndComments.elm.js+7−13

@@ -1,13 +1,7 @@

1−Elm.Main = Elm.Main || {};

2−Elm.Main.make = function (_elm) {

3− "use strict";

4− _elm.Main = _elm.Main || {};

5− if (_elm.Main.values) return _elm.Main.values;

6− var _U = Elm.Native.Utils.make(_elm);

7− var _op = {};

8− var commentStart = "{-";

9− var singleQuote = _U.chr("\'");

10− var doubleQuote = _U.chr("\"");

11− var variablesWithPrimes = function (x) { var x$ = x;return x$;};

12− return _elm.Main.values = {_op: _op,variablesWithPrimes: variablesWithPrimes,doubleQuote: doubleQuote,singleQuote: singleQuote,commentStart: commentStart};

13−};

1+var _elm_lang$core$Main$commentStart = '{-';

2+var _elm_lang$core$Main$singleQuote = _elm_lang$core$Native_Utils.chr('\'');

3+var _elm_lang$core$Main$doubleQuote = _elm_lang$core$Native_Utils.chr('\"');

4+var _elm_lang$core$Main$variablesWithPrimes = function (x) {

5+ var x$ = x;

6+ return x$;

7+};

tests/test-files/good/Declarations/Ports.elmdeleted−21

@@ -1,21 +0,0 @@

1−

2−-- incoming

3−port userID : String

4−port number : Int

5−port tuple : (Float,Bool)

6−port array : List Float

7−port record : { x:Float, y:Float }

8−

9−-- outgoing

10−port fortyTwo : Int

11−port fortyTwo =

12− 42

13−

14−

15−port time : Float

16−port time =

17− 3.14

18−

19−port students : List { name:String, age:Int }

20−port students =

21− [ { name = "Tom", age = 42 } ]

tests/test-files/good/Declarations/PortsWithTypeAliases.elmdeleted−13

@@ -1,13 +0,0 @@

1−

2−

3−type alias Point2D =

4− Point Float Float

5−

6−type alias Point x y =

7− { x:x, y:y }

8−

9−

10−port points : Point2D

11−

12−

13−port pairs : Point String String