9e7ff43 · elk · git.iko.soy

.gitignore+2

compare with master

unifiedsplit

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

1dist

2cabal-dev

3+.cabal-sandbox/

4+cabal.sandbox.config

3*.o

5*.o

4*.hi

6*.hi

5*.chi

7*.chi

.gitmodules−3

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

1[submodule "IO"]

2 path = IO

3 url = https://github.com/maxsnew/IO.git

4−[submodule "automaton"]

5− path = automaton

6− url = https://github.com/evancz/automaton.git

7[submodule "Elm-Test"]

4[submodule "Elm-Test"]

8 path = Elm-Test

5 path = Elm-Test

9 url = https://github.com/deadfoxygrandpa/Elm-Test.git

6 url = https://github.com/deadfoxygrandpa/Elm-Test.git

Elm-Test+1−1

Submodule changed.

Elm.cabal+50−39

@@ -37,28 +37,35 @@ Library

37 Elm.Internal.Utils,

38 Elm.Internal.Version

39 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Annotation,

40+ other-modules: AST.Annotation,

41− SourceSyntax.Declaration,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

42− SourceSyntax.Expression,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

43− SourceSyntax.Helpers,

46+ AST.Helpers,

44− SourceSyntax.Literal,

47+ AST.Literal,

45− SourceSyntax.Module,

48+ AST.Module,

46− SourceSyntax.Pattern,

49+ AST.Pattern,

47− SourceSyntax.PrettyPrint,

50+ AST.PrettyPrint,

48− SourceSyntax.Type,

51+ AST.Type,

49− SourceSyntax.Variable,

52+ AST.Variable,

50 Generate.JavaScript,

53 Generate.JavaScript,

51 Generate.JavaScript.Helpers,

54 Generate.JavaScript.Helpers,

52 Generate.JavaScript.Ports,

55 Generate.JavaScript.Ports,

56+ Generate.JavaScript.Variable,

53 Generate.Markdown,

57 Generate.Markdown,

54 Generate.Html,

58 Generate.Html,

55 Generate.Cases,

59 Generate.Cases,

56 Transform.Canonicalize,

60 Transform.Canonicalize,

61+ Transform.Canonicalize.Environment,

62+ Transform.Canonicalize.Setup,

63+ Transform.Canonicalize.Type,

64+ Transform.Canonicalize.Variable,

57 Transform.Check,

65 Transform.Check,

58 Transform.Expression,

66 Transform.Expression,

59 Transform.Declaration,

67 Transform.Declaration,

60 Transform.Definition,

68 Transform.Definition,

61− Transform.SafeNames,

62 Transform.SortDefinitions,

69 Transform.SortDefinitions,

63 Transform.Substitute,

70 Transform.Substitute,

64 Metadata.Prelude,

71 Metadata.Prelude,

@@ -71,8 +78,6 @@ Library

71 Parse.Parse,

78 Parse.Parse,

72 Parse.Pattern,

79 Parse.Pattern,

73 Parse.Type,

80 Parse.Type,

74− Type.Alias,

75− Type.Constrain.Declaration,

76 Type.Constrain.Expression,

81 Type.Constrain.Expression,

77 Type.Constrain.Literal,

82 Type.Constrain.Literal,

78 Type.Constrain.Pattern,

83 Type.Constrain.Pattern,

@@ -123,28 +128,35 @@ Executable elm

123 Main-is: Compiler.hs

128 Main-is: Compiler.hs

124 ghc-options: -threaded -O2

129 ghc-options: -threaded -O2

125 Hs-Source-Dirs: compiler

130 Hs-Source-Dirs: compiler

126− other-modules: SourceSyntax.Annotation,

131+ other-modules: AST.Annotation,

127− SourceSyntax.Declaration,

132+ AST.Declaration,

133+ AST.Expression.General,

134+ AST.Expression.Source,

128− SourceSyntax.Expression,

135+ AST.Expression.Valid,

136+ AST.Expression.Canonical,

129− SourceSyntax.Helpers,

137+ AST.Helpers,

130− SourceSyntax.Literal,

138+ AST.Literal,

131− SourceSyntax.Module,

139+ AST.Module,

132− SourceSyntax.Pattern,

140+ AST.Pattern,

133− SourceSyntax.PrettyPrint,

141+ AST.PrettyPrint,

134− SourceSyntax.Type,

142+ AST.Type,

135− SourceSyntax.Variable,

143+ AST.Variable,

136 Generate.JavaScript,

144 Generate.JavaScript,

137 Generate.JavaScript.Helpers,

145 Generate.JavaScript.Helpers,

138 Generate.JavaScript.Ports,

146 Generate.JavaScript.Ports,

147+ Generate.JavaScript.Variable,

139 Generate.Markdown,

148 Generate.Markdown,

140 Generate.Html,

149 Generate.Html,

141 Generate.Cases,

150 Generate.Cases,

142 Transform.Canonicalize,

151 Transform.Canonicalize,

152+ Transform.Canonicalize.Environment,

153+ Transform.Canonicalize.Setup,

154+ Transform.Canonicalize.Type,

155+ Transform.Canonicalize.Variable,

143 Transform.Check,

156 Transform.Check,

144 Transform.Expression,

157 Transform.Expression,

145 Transform.Declaration,

158 Transform.Declaration,

146 Transform.Definition,

159 Transform.Definition,

147− Transform.SafeNames,

148 Transform.SortDefinitions,

160 Transform.SortDefinitions,

149 Transform.Substitute,

161 Transform.Substitute,

150 Metadata.Prelude,

162 Metadata.Prelude,

@@ -157,8 +169,6 @@ Executable elm

157 Parse.Parse,

169 Parse.Parse,

158 Parse.Pattern,

170 Parse.Pattern,

159 Parse.Type,

171 Parse.Type,

160− Type.Alias,

161− Type.Constrain.Declaration,

162 Type.Constrain.Expression,

172 Type.Constrain.Expression,

163 Type.Constrain.Literal,

173 Type.Constrain.Literal,

164 Type.Constrain.Pattern,

174 Type.Constrain.Pattern,

@@ -208,16 +218,16 @@ Executable elm

208Executable elm-doc

218Executable elm-doc

209 Main-is: Docs.hs

219 Main-is: Docs.hs

210 Hs-Source-Dirs: compiler

220 Hs-Source-Dirs: compiler

211− other-modules: SourceSyntax.Annotation,

221+ other-modules: AST.Annotation,

212− SourceSyntax.Declaration,

222+ AST.Declaration,

213− SourceSyntax.Expression,

223+ AST.Expression.General,

214− SourceSyntax.Helpers,

224+ AST.Helpers,

215− SourceSyntax.Literal,

225+ AST.Literal,

216− SourceSyntax.Module,

226+ AST.Module,

217− SourceSyntax.Pattern,

227+ AST.Pattern,

218− SourceSyntax.PrettyPrint,

228+ AST.PrettyPrint,

219− SourceSyntax.Type,

229+ AST.Type,

220− SourceSyntax.Variable,

230+ AST.Variable,

221 Parse.Binop,

231 Parse.Binop,

222 Parse.Declaration,

232 Parse.Declaration,

223 Parse.Expression,

233 Parse.Expression,

@@ -244,6 +254,7 @@ Executable elm-doc

244 pretty,

254 pretty,

245 scientific,

255 scientific,

246 text,

256 text,

257+ transformers >= 0.2,

247 union-find,

258 union-find,

248 yaml

259 yaml

249

260

@@ -254,9 +265,9 @@ Test-Suite compiler-tests

254 other-modules: Tests.Compiler

265 other-modules: Tests.Compiler

255 Tests.Property

266 Tests.Property

256 Tests.Property.Arbitrary

267 Tests.Property.Arbitrary

257− SourceSyntax.Helpers

268+ AST.Helpers

258− SourceSyntax.Literal

269+ AST.Literal

259− SourceSyntax.PrettyPrint

270+ AST.PrettyPrint

260 build-depends: test-framework,

271 build-depends: test-framework,

261 test-framework-hunit,

272 test-framework-hunit,

262 test-framework-quickcheck2 >= 0.3,

273 test-framework-quickcheck2 >= 0.3,

IO+1−1

Submodule changed.

automatondeleted−1

Submodule changed.

changelog.md+32−1

@@ -1,7 +1,38 @@

1

2+## 0.13

3+

4+#### Improvements:

5+

6+ * Type aliases in port types

7+ * Add Keyboard.alt and Keyboard.meta

8+ * Add Debug.crash

9+ * Add List.indexedMap and List.filterMap

10+ * Add Maybe.map

11+ * Add --bundle-runtime flag which creates stand-alone Elm programs

12+ * Error on ambiguious use of imported variables

13+ * Better architecture for compiler. Uses types to make compilation pipeline

14+ safer, setting things up for giving programmatic access to the AST to

15+ improve editor and IDE support.

16+

17+#### Breaking Changes:

18+

19+ * Rename Maybe.maybe to Maybe.extract

20+ * Rename Either.either to Either.extract

21+ * Remove Maybe.justs for (List.filterMap id)

22+ * Remove List.and for (List.foldl (&&) True)

23+ * Remove List.or for (List.foldl (||) False)

24+ * Unambiguous syntax for importing ADTs and type aliases (whoo!)

25+ * sqrt and logBase both only work on Floats now

26+

27+## 0.12.3

28+

29+ * Minor changes to support webgl as a separate library

30+ * Switch from HSV to HSL

31+ * Programmatic access to colors with toHsl and toRgb

32+

2## 0.12.1

33## 0.12.1

3

34

4−## Improvements:

35+#### Improvements:

5

36

6 * New Array library (thanks entirely to @Xashili)

37 * New Array library (thanks entirely to @Xashili)

7 * Json.Value can flow through ports

38 * Json.Value can flow through ports

compiler/SourceSyntax/Annotation.hs → compiler/AST/Annotation.hsrenamed+2−2

@@ -1,9 +1,9 @@

1{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Annotation where

2+module AST.Annotation where

3

4import qualified Text.Parsec.Pos as Parsec

5import qualified Text.PrettyPrint as P

6−import SourceSyntax.PrettyPrint

6+import AST.PrettyPrint

7

8data Annotated annotation expr = A annotation expr

9 deriving (Show)

compiler/SourceSyntax/Declaration.hs → compiler/AST/Declaration.hsrenamed+27−20

@@ -1,16 +1,19 @@

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Declaration where

2+module AST.Declaration where

3

4import Data.Binary

5−import qualified SourceSyntax.Expression as Expr

5+import qualified AST.Expression.Source as Source

6+import qualified AST.Expression.Valid as Valid

7+import qualified AST.Expression.Canonical as Canonical

6−import qualified SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

7−import SourceSyntax.PrettyPrint

10+import AST.PrettyPrint

8import Text.PrettyPrint as P

11import Text.PrettyPrint as P

9

12

10−data Declaration' port def

13+data Declaration' port def var

11 = Definition def

14 = Definition def

12− | Datatype String [String] [(String,[T.Type])]

15+ | Datatype String [String] [(String, [T.Type var])]

13− | TypeAlias String [String] T.Type

16+ | TypeAlias String [String] (T.Type var)

14 | Port port

17 | Port port

15 | Fixity Assoc Int String

18 | Fixity Assoc Int String

16 deriving (Show)

19 deriving (Show)

@@ -18,25 +21,28 @@ data Declaration' port def

18data Assoc = L | N | R

21data Assoc = L | N | R

19 deriving (Eq)

22 deriving (Eq)

20

23

21−data ParsePort

24+data RawPort

22− = PPAnnotation String T.Type

25+ = PPAnnotation String T.RawType

23− | PPDef String Expr.ParseExpr

26+ | PPDef String Source.Expr

24 deriving (Show)

27 deriving (Show)

25

28

26−data Port

29+data Port expr var

27− = Out String Expr.Expr T.Type

30+ = Out String expr (T.Type var)

28− | In String T.Type

31+ | In String (T.Type var)

29 deriving (Show)

32 deriving (Show)

30

33

34+type SourceDecl = Declaration' RawPort Source.Def Var.Raw

35+type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw

36+type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical)

37+ Canonical.Def

38+ Var.Canonical

39+

31−portName :: Port -> String

40+portName :: Port expr var -> String

32portName port =

41portName port =

33 case port of

42 case port of

34 Out name _ _ -> name

43 Out name _ _ -> name

35 In name _ -> name

44 In name _ -> name

36

45

37−type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

38−type Declaration = Declaration' Port Expr.Def

39−

40instance Show Assoc where

46instance Show Assoc where

41 show assoc =

47 show assoc =

42 case assoc of

48 case assoc of

@@ -54,7 +60,8 @@ instance Binary Assoc where

54

60

55 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

61 put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

56

62

63+instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

57−instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

64+ Pretty (Declaration' port def var) where

58 pretty decl =

65 pretty decl =

59 case decl of

66 case decl of

60 Definition def -> pretty def

67 Definition def -> pretty def

@@ -81,13 +88,13 @@ instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

81 N -> P.empty

88 N -> P.empty

82 R -> P.text "r"

89 R -> P.text "r"

83

90

84−instance Pretty ParsePort where

91+instance Pretty RawPort where

85 pretty port =

92 pretty port =

86 case port of

93 case port of

87 PPAnnotation name tipe -> prettyPort name ":" tipe

94 PPAnnotation name tipe -> prettyPort name ":" tipe

88 PPDef name expr -> prettyPort name "=" expr

95 PPDef name expr -> prettyPort name "=" expr

89

96

90−instance Pretty Port where

97+instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where

91 pretty port =

98 pretty port =

92 case port of

99 case port of

93 In name tipe -> prettyPort name ":" tipe

100 In name tipe -> prettyPort name ":" tipe

compiler/AST/Expression/Canonical.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Canonical where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (CanonicalType)

9+import qualified AST.Annotation as Annotation

10+import qualified AST.Pattern as Pattern

11+import qualified AST.Variable as Var

12+

13+

14+{-| Canonicalized expressions. All variables are fully resolved to the module

15+they came from.

16+-}

17+type Expr = General.Expr Annotation.Region Def Var.Canonical

18+type Expr' = General.Expr' Annotation.Region Def Var.Canonical

19+

20+data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType)

21+ deriving (Show)

22+

23+instance Pretty Def where

24+ pretty (Definition pattern expr maybeTipe) =

25+ P.vcat [ annotation, definition ]

26+ where

27+ definition = pretty pattern <+> P.equals <+> pretty expr

28+ annotation = case maybeTipe of

29+ Nothing -> P.empty

30+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/SourceSyntax/Expression.hs → compiler/AST/Expression/General.hsrenamed+50−87

@@ -6,16 +6,17 @@ The others are specialized versions of the AST that represent specific phases

6of the compilation process. I expect there to be more phases as we begin to

7enrich the AST with more information.

8-}

9−module SourceSyntax.Expression where

9+module AST.Expression.General where

10

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import qualified SourceSyntax.Helpers as Help

13+import AST.Type (Type)

14+

15+import qualified AST.Annotation as Annotation

16+import qualified AST.Helpers as Help

14−import qualified SourceSyntax.Annotation as Annotation

17+import qualified AST.Literal as Literal

15−import qualified SourceSyntax.Pattern as Pattern

18+import qualified AST.Pattern as Pattern

16−import qualified SourceSyntax.Type as SrcType

19+import qualified AST.Variable as Var

17−import qualified SourceSyntax.Literal as Literal

18−import qualified SourceSyntax.Variable as Variable

19

20

20---- GENERAL AST ----

21---- GENERAL AST ----

21

22

@@ -34,80 +35,57 @@ move through the compilation process. The type holes are used to represent:

34 with information about what module a variable came from.

35 with information about what module a variable came from.

35

36

36-}

37-}

37−type GeneralExpr annotation definition variable =

38+type Expr annotation definition variable =

38− Annotation.Annotated annotation (GeneralExpr' annotation definition variable)

39+ Annotation.Annotated annotation (Expr' annotation definition variable)

39

40

40−data GeneralExpr' ann def var

41+data Expr' ann def var

41 = Literal Literal.Literal

42 = Literal Literal.Literal

42 | Var var

43 | Var var

43− | Range (GeneralExpr ann def var) (GeneralExpr ann def var)

44+ | Range (Expr ann def var) (Expr ann def var)

44− | ExplicitList [GeneralExpr ann def var]

45+ | ExplicitList [Expr ann def var]

45− | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)

46+ | Binop var (Expr ann def var) (Expr ann def var)

46− | Lambda Pattern.Pattern (GeneralExpr ann def var)

47+ | Lambda (Pattern.Pattern var) (Expr ann def var)

47− | App (GeneralExpr ann def var) (GeneralExpr ann def var)

48+ | App (Expr ann def var) (Expr ann def var)

48− | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]

49+ | MultiIf [(Expr ann def var,Expr ann def var)]

49− | Let [def] (GeneralExpr ann def var)

50+ | Let [def] (Expr ann def var)

50− | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]

51+ | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]

51− | Data String [GeneralExpr ann def var]

52+ | Data String [Expr ann def var]

52− | Access (GeneralExpr ann def var) String

53+ | Access (Expr ann def var) String

53− | Remove (GeneralExpr ann def var) String

54+ | Remove (Expr ann def var) String

54− | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)

55+ | Insert (Expr ann def var) String (Expr ann def var)

55− | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]

56+ | Modify (Expr ann def var) [(String, Expr ann def var)]

56− | Record [(String, GeneralExpr ann def var)]

57+ | Record [(String, Expr ann def var)]

57− | Markdown String String [GeneralExpr ann def var]

58+ | Markdown String String [Expr ann def var]

58 -- for type checking and code gen only

59 -- for type checking and code gen only

59− | PortIn String SrcType.Type

60+ | PortIn String (Type var)

60− | PortOut String SrcType.Type (GeneralExpr ann def var)

61+ | PortOut String (Type var) (Expr ann def var)

61 | GLShader String String Literal.GLShaderTipe

62 | GLShader String String Literal.GLShaderTipe

62 deriving (Show)

63 deriving (Show)

63

64

65

65−---- SPECIALIZED ASTs ----

66−

67−{-| Expressions created by the parser. These use a split representation of type

68−annotations and definitions, which is how they appear in source code and how

69−they are parsed.

70−-}

71−type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw

72−type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw

73−

74−data ParseDef

75− = Def Pattern.Pattern ParseExpr

76− | TypeAnnotation String SrcType.Type

77− deriving (Show)

78−

79−{-| "Normal" expressions. When the compiler checks that type annotations and

80−ports are all paired with definitions in the appropriate order, it collapses

81−them into a Def that is easier to work with in later phases of compilation.

82−-}

83−type Expr = GeneralExpr Annotation.Region Def Variable.Raw

84−type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw

85−

86−data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)

87− deriving (Show)

88−

89−

90−

91---- UTILITIES ----

66---- UTILITIES ----

92

67

93−rawVar :: String -> GeneralExpr' ann def Variable.Raw

68+rawVar :: String -> Expr' ann def Var.Raw

94−rawVar x = Var (Variable.Raw x)

69+rawVar x = Var (Var.Raw x)

70+

71+localVar :: String -> Expr' ann def Var.Canonical

72+localVar x = Var (Var.Canonical Var.Local x)

95

73

96−tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var

74+tuple :: [Expr ann def var] -> Expr' ann def var

97tuple es = Data ("_Tuple" ++ show (length es)) es

75tuple es = Data ("_Tuple" ++ show (length es)) es

98

76

99−delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]

77+delist :: Expr ann def var -> [Expr ann def var]

100delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

78delist (Annotation.A _ (Data "::" [h,t])) = h : delist t

101delist _ = []

79delist _ = []

102

80

103saveEnvName :: String

81saveEnvName :: String

104saveEnvName = "_save_the_environment!!!"

82saveEnvName = "_save_the_environment!!!"

105

83

106−dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw

84+dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical

107dummyLet defs =

85dummyLet defs =

108− Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)

86+ Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))

109

87

110−instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

88+instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where

111 pretty expr =

89 pretty expr =

112 case expr of

90 case expr of

113 Literal lit -> pretty lit

91 Literal lit -> pretty lit

@@ -118,12 +96,14 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

118

96

119 ExplicitList es -> P.brackets (commaCat (map pretty es))

97 ExplicitList es -> P.brackets (commaCat (map pretty es))

120

98

121− Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->

99+ Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e

100+ | Var.toString op == "-" ->

122− P.text "-" <> prettyParens e

101+ P.text "-" <> prettyParens e

123

102

124− Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

103+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op'', prettyParens e2 ]

125 where

104 where

105+ op' = Var.toString op

126− op' = if Help.isOp op then op else "`" ++ op ++ "`"

106+ op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"

127

107

128 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

108 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

129 where

109 where

@@ -179,36 +159,19 @@ instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where

179

159

180 Markdown _ _ _ -> P.text "[markdown| ... |]"

160 Markdown _ _ _ -> P.text "[markdown| ... |]"

181

161

182− GLShader _ _ _ -> P.text "[glShader| ... |]"

162+ GLShader _ _ _ -> P.text "[glsl| ... |]"

183

163

184 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

164 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

185

165

186 PortOut _ _ signal -> pretty signal

166 PortOut _ _ signal -> pretty signal

187

167

188−instance Pretty ParseDef where

189− pretty def =

190− case def of

191− TypeAnnotation name tipe ->

192− variable name <+> P.colon <+> pretty tipe

193− Def pattern expr ->

194− pretty pattern <+> P.equals <+> pretty expr

195−

196−instance Pretty Def where

197− pretty (Definition pattern expr maybeTipe) =

198− P.vcat [ annotation, definition ]

199− where

200− definition = pretty pattern <+> P.equals <+> pretty expr

201− annotation = case maybeTipe of

202− Nothing -> P.empty

203− Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

204−

205−collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]

168+collectApps :: Expr ann def var -> [Expr ann def var]

206collectApps annExpr@(Annotation.A _ expr) =

169collectApps annExpr@(Annotation.A _ expr) =

207 case expr of

170 case expr of

208 App a b -> collectApps a ++ [b]

171 App a b -> collectApps a ++ [b]

209 _ -> [annExpr]

172 _ -> [annExpr]

210

173

211−collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)

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

212collectLambdas lexpr@(Annotation.A _ expr) =

175collectLambdas lexpr@(Annotation.A _ expr) =

213 case expr of

176 case expr of

214 Lambda pattern body ->

177 Lambda pattern body ->

@@ -217,7 +180,7 @@ collectLambdas lexpr@(Annotation.A _ expr) =

217

180

218 _ -> ([], lexpr)

181 _ -> ([], lexpr)

219

182

220−prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc

183+prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc

221prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

184prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

222 where

185 where

223 needed =

186 needed =

@@ -228,5 +191,5 @@ prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)

228 MultiIf _ -> True

191 MultiIf _ -> True

229 Let _ _ -> True

192 Let _ _ -> True

230 Case _ _ -> True

193 Case _ _ -> True

231− Data name (_:_) -> name /= "::"

194+ Data name (_:_) -> not (name == "::" || Help.isTuple name)

232 _ -> False

195 _ -> False

compiler/AST/Expression/Source.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Source where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (RawType)

9+import qualified AST.Variable as Var

10+import qualified AST.Annotation as Annotation

11+import qualified AST.Pattern as Pattern

12+

13+

14+{-| Expressions created by the parser. These use a split representation of type

15+annotations and definitions, which is how they appear in source code and how

16+they are parsed.

17+-}

18+type Expr = General.Expr Annotation.Region Def Var.Raw

19+type Expr' = General.Expr' Annotation.Region Def Var.Raw

20+

21+data Def

22+ = Definition Pattern.RawPattern Expr

23+ | TypeAnnotation String RawType

24+ deriving (Show)

25+

26+instance Pretty Def where

27+ pretty def =

28+ case def of

29+ TypeAnnotation name tipe ->

30+ variable name <+> P.colon <+> pretty tipe

31+ Definition pattern expr ->

32+ pretty pattern <+> P.equals <+> pretty expr

compiler/AST/Expression/Valid.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# OPTIONS_GHC -Wall #-}

2+

3+module AST.Expression.Valid where

4+

5+import AST.PrettyPrint

6+import Text.PrettyPrint as P

7+import qualified AST.Expression.General as General

8+import AST.Type (RawType)

9+import qualified AST.Variable as Var

10+import qualified AST.Annotation as Annotation

11+import qualified AST.Pattern as Pattern

12+

13+

14+{-| "Normal" expressions. When the compiler checks that type annotations and

15+ports are all paired with definitions in the appropriate order, it collapses

16+them into a Def that is easier to work with in later phases of compilation.

17+-}

18+type Expr = General.Expr Annotation.Region Def Var.Raw

19+type Expr' = General.Expr' Annotation.Region Def Var.Raw

20+

21+data Def = Definition Pattern.RawPattern Expr (Maybe RawType)

22+ deriving (Show)

23+

24+instance Pretty Def where

25+ pretty (Definition pattern expr maybeTipe) =

26+ P.vcat [ annotation, definition ]

27+ where

28+ definition = pretty pattern <+> P.equals <+> pretty expr

29+ annotation = case maybeTipe of

30+ Nothing -> P.empty

31+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

compiler/SourceSyntax/Helpers.hs → compiler/AST/Helpers.hsrenamed+1−1

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

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Helpers where

2+module AST.Helpers where

3

4import qualified Data.Char as Char

5

compiler/SourceSyntax/Literal.hs → compiler/AST/Literal.hsrenamed+2−2

@@ -1,8 +1,8 @@

1{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Literal where

2+module AST.Literal where

3

4+import AST.PrettyPrint

4import Data.Map (Map)

5import Data.Map (Map)

5−import SourceSyntax.PrettyPrint

6import qualified Text.PrettyPrint as PP

7

8data Literal = IntNum Int

compiler/AST/Module.hsnew file+125

@@ -0,0 +1,125 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Module where

3+

4+import Data.Binary

5+import qualified Data.List as List

6+import qualified Data.Map as Map

7+import Control.Applicative ((<$>),(<*>))

8+

9+import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Declaration as Decl

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+

14+import AST.PrettyPrint

15+import Text.PrettyPrint as P

16+

17+import qualified Elm.Internal.Version as Version

18+

19+data Module exs body = Module

20+ { names :: [String]

21+ , path :: FilePath

22+ , exports :: exs

23+ , imports :: [(String, ImportMethod)]

24+ , body :: body

25+ }

26+

27+getName :: Module exs body -> String

28+getName modul =

29+ List.intercalate "." (names modul)

30+

31+data CanonicalBody = CanonicalBody

32+ { program :: Canonical.Expr

33+ , types :: Types

34+ , fixities :: [(Decl.Assoc, Int, String)]

35+ , aliases :: Aliases

36+ , datatypes :: ADTs

37+ , ports :: [String]

38+ }

39+

40+type SourceModule = Module (Var.Listing Var.Value) [Decl.SourceDecl]

41+type ValidModule = Module (Var.Listing Var.Value) [Decl.ValidDecl]

42+type CanonicalModule = Module [Var.Value] CanonicalBody

43+

44+type Interfaces = Map.Map String Interface

45+

46+type Types = Map.Map String Type.CanonicalType

47+type Aliases = Map.Map String ( [String], Type.CanonicalType )

48+type ADTs = Map.Map String (AdtInfo String)

49+

50+type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )

51+type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

52+

53+data Interface = Interface

54+ { iVersion :: Version.Version

55+ , iTypes :: Types

56+ , iImports :: [(String, ImportMethod)]

57+ , iAdts :: ADTs

58+ , iAliases :: Aliases

59+ , iFixities :: [(Decl.Assoc, Int, String)]

60+ , iPorts :: [String]

61+ }

62+

63+toInterface :: CanonicalModule -> Interface

64+toInterface modul =

65+ let body' = body modul in

66+ Interface

67+ { iVersion = Version.elmVersion

68+ , iTypes = types body'

69+ , iImports = imports modul

70+ , iAdts = datatypes body'

71+ , iAliases = aliases body'

72+ , iFixities = fixities body'

73+ , iPorts = ports body'

74+ }

75+

76+instance Binary Interface where

77+ get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get

78+ put modul = do

79+ put (iVersion modul)

80+ put (iTypes modul)

81+ put (iImports modul)

82+ put (iAdts modul)

83+ put (iAliases modul)

84+ put (iFixities modul)

85+ put (iPorts modul)

86+

87+data ImportMethod

88+ = As !String

89+ | Open !(Var.Listing Var.Value)

90+

91+open :: ImportMethod

92+open = Open (Var.openListing)

93+

94+importing :: [Var.Value] -> ImportMethod

95+importing xs = Open (Var.Listing xs False)

96+

97+instance Binary ImportMethod where

98+ put method =

99+ case method of

100+ As alias -> putWord8 0 >> put alias

101+ Open listing -> putWord8 1 >> put listing

102+

103+ get = do tag <- getWord8

104+ case tag of

105+ 0 -> As <$> get

106+ 1 -> Open <$> get

107+ _ -> error "Error reading valid ImportMethod type from serialized string"

108+

109+instance (Pretty exs, Pretty body) => Pretty (Module exs body) where

110+ pretty (Module names _ exs ims body) =

111+ P.vcat [modul, P.text "", prettyImports, P.text "", pretty body]

112+ where

113+ modul = P.text "module" <+> name <+> pretty exs <+> P.text "where"

114+ name = P.text (List.intercalate "." names)

115+

116+ prettyImports = P.vcat $ map prettyMethod ims

117+

118+prettyMethod :: (String, ImportMethod) -> Doc

119+prettyMethod (name, method) =

120+ case method of

121+ As alias

122+ | name == alias -> P.empty

123+ | otherwise -> P.text "as" <+> P.text alias

124+

125+ Open listing -> pretty listing

compiler/AST/Pattern.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module AST.Pattern where

3+

4+import qualified AST.Helpers as Help

5+import AST.PrettyPrint

6+import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

8+

9+import qualified AST.Variable as Var

10+import AST.Literal as Literal

11+

12+data Pattern var

13+ = Data var [Pattern var]

14+ | Record [String]

15+ | Alias String (Pattern var)

16+ | Var String

17+ | Anything

18+ | Literal Literal.Literal

19+ deriving (Eq, Ord, Show)

20+

21+type RawPattern = Pattern Var.Raw

22+type CanonicalPattern = Pattern Var.Canonical

23+

24+cons :: RawPattern -> RawPattern -> RawPattern

25+cons h t = Data (Var.Raw "::") [h,t]

26+

27+nil :: RawPattern

28+nil = Data (Var.Raw "[]") []

29+

30+list :: [RawPattern] -> RawPattern

31+list = foldr cons nil

32+

33+tuple :: [RawPattern] -> RawPattern

34+tuple es = Data (Var.Raw ("_Tuple" ++ show (length es))) es

35+

36+boundVarList :: Pattern var -> [String]

37+boundVarList = Set.toList . boundVars

38+

39+boundVars :: Pattern var -> Set.Set String

40+boundVars pattern =

41+ case pattern of

42+ Var x -> Set.singleton x

43+ Alias x p -> Set.insert x (boundVars p)

44+ Data _ ps -> Set.unions (map boundVars ps)

45+ Record fields -> Set.fromList fields

46+ Anything -> Set.empty

47+ Literal _ -> Set.empty

48+

49+

50+instance Var.ToString var => Pretty (Pattern var) where

51+ pretty pattern =

52+ case pattern of

53+ Var x -> variable x

54+ Literal lit -> pretty lit

55+ Record fs -> PP.braces (commaCat $ map variable fs)

56+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

57+ Anything -> PP.text "_"

58+ Data name [hd,tl] | Var.toString name == "::" ->

59+ parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

60+ where

61+ isCons = case hd of

62+ Data ctor _ -> Var.toString ctor == "::"

63+ _ -> False

64+

65+ Data name ps

66+ | Help.isTuple name' -> PP.parens . commaCat $ map pretty ps

67+ | otherwise -> hsep (PP.text name' : map prettyParens ps)

68+ where

69+ name' = Var.toString name

70+

71+prettyParens :: Var.ToString var => Pattern var -> Doc

72+prettyParens pattern =

73+ parensIf needsThem (pretty pattern)

74+ where

75+ needsThem =

76+ case pattern of

77+ Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True

78+ Alias _ _ -> True

79+ _ -> False

compiler/SourceSyntax/PrettyPrint.hs → compiler/AST/PrettyPrint.hsrenamed+14−11

@@ -1,14 +1,18 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+module AST.PrettyPrint where

1

3

2−module SourceSyntax.PrettyPrint where

4+import Control.Monad.Trans.Error

3−

4−import Text.PrettyPrint

5+import Text.PrettyPrint as P

5−import qualified SourceSyntax.Helpers as Help

6+import qualified AST.Helpers as Help

6

7

7class Pretty a where

8class Pretty a where

8 pretty :: a -> Doc

9 pretty :: a -> Doc

9

10

10−instance Pretty () where

11+instance Pretty Doc where

11− pretty () = empty

12+ pretty doc = doc

13+

14+instance Pretty String where

15+ pretty = P.text

12

16

13renderPretty :: (Pretty a) => a -> String

17renderPretty :: (Pretty a) => a -> String

14renderPretty e = render (pretty e)

18renderPretty e = render (pretty e)

@@ -21,11 +25,7 @@ parensIf bool doc = if bool then parens doc else doc

21

25

22variable :: String -> Doc

26variable :: String -> Doc

23variable x =

27variable x =

24− if Help.isOp x then parens (text x)

28+ if Help.isOp x then parens (text x) else text x

25− else text (reprime x)

26−

27−reprime :: String -> String

28−reprime = map (\c -> if c == '$' then '\'' else c)

29

30eightyCharLines :: Int -> String -> String

31eightyCharLines indent message = answer

@@ -37,3 +37,6 @@ eightyCharLines indent message = answer

37 step (sentence, slen, space) (word, wlen)

38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

40+

41+instance ErrorList Doc where

42+ listMsg str = [ P.text str ]

compiler/AST/Type.hsnew file+138

@@ -0,0 +1,138 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Type where

3+

4+import Control.Applicative ((<$>), (<*>))

5+import Data.Binary

6+import qualified Data.Map as Map

7+

8+import qualified AST.Variable as Var

9+import AST.PrettyPrint

10+import qualified AST.Helpers as Help

11+import Text.PrettyPrint as P

12+

13+data Type var

14+ = Lambda (Type var) (Type var)

15+ | Var String

16+ | Type var

17+ | App (Type var) [Type var]

18+ | Record [(String, Type var)] (Maybe (Type var))

19+ | Aliased Var.Canonical (Type var)

20+ deriving (Eq,Show)

21+

22+type RawType = Type Var.Raw

23+type CanonicalType = Type Var.Canonical

24+

25+fieldMap :: [(String,a)] -> Map.Map String [a]

26+fieldMap fields =

27+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

28+

29+recordOf :: [(String, Type var)] -> Type var

30+recordOf fields = Record fields Nothing

31+

32+listOf :: RawType -> RawType

33+listOf t = App (Type (Var.Raw "_List")) [t]

34+

35+tupleOf :: [RawType] -> RawType

36+tupleOf ts = App (Type t) ts

37+ where

38+ t = Var.Raw ("_Tuple" ++ show (length ts))

39+

40+instance (Var.ToString var, Pretty var) => Pretty (Type var) where

41+ pretty tipe =

42+ case tipe of

43+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

44+ where

45+ t:ts = map prettyLambda (collectLambdas tipe)

46+ prettyLambda t = case t of

47+ Lambda _ _ -> P.parens (pretty t)

48+ _ -> pretty t

49+

50+ Var x -> P.text x

51+

52+ Type var ->

53+ let v = Var.toString var in

54+ P.text (if v == "_Tuple0" then "()" else v)

55+

56+ App f args ->

57+ case (f,args) of

58+ (Type name, [t])

59+ | Var.toString name == "_List" -> P.brackets (pretty t)

60+

61+ (Type name, _)

62+ | Help.isTuple (Var.toString name) ->

63+ P.parens . P.sep . P.punctuate P.comma $ map pretty args

64+

65+ _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)

66+

67+ Record _ _ ->

68+ P.braces $ case flattenRecord tipe of

69+ (fields, Nothing) -> prettyFields fields

70+ (fields, Just x) ->

71+ P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)

72+ where

73+ prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

74+ prettyFields fields = commaSep (map prettyField fields)

75+

76+ Aliased name t ->

77+ let t' = pretty t in

78+ if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]

79+ then t'

80+ else pretty name

81+

82+collectLambdas :: Type var -> [Type var]

83+collectLambdas tipe =

84+ case tipe of

85+ Lambda arg body -> arg : collectLambdas body

86+ _ -> [tipe]

87+

88+prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc

89+prettyParens tipe = parensIf (needed tipe) (pretty tipe)

90+ where

91+ needed t =

92+ case t of

93+ Aliased _ t' -> needed t'

94+

95+ Lambda _ _ -> True

96+

97+ App (Type name) [_] | Var.toString name == "_List" -> False

98+ App (Type name) _ | Help.isTuple (Var.toString name) -> False

99+ App t' [] -> needed t'

100+ App _ _ -> True

101+

102+ _ -> False

103+

104+flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )

105+flattenRecord tipe =

106+ case tipe of

107+ Var x -> ([], Just x)

108+

109+ Record fields Nothing -> (fields, Nothing)

110+

111+ Record fields (Just ext) ->

112+ let (fields',ext') = flattenRecord ext

113+ in (fields' ++ fields, ext')

114+

115+ Aliased _ tipe' -> flattenRecord tipe'

116+

117+ _ -> error "Trying to flatten ill-formed record."

118+

119+instance Binary var => Binary (Type var) where

120+ put tipe =

121+ case tipe of

122+ Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2

123+ Var x -> putWord8 1 >> put x

124+ Type name -> putWord8 2 >> put name

125+ App t1 t2 -> putWord8 3 >> put t1 >> put t2

126+ Record fs ext -> putWord8 4 >> put fs >> put ext

127+ Aliased var t -> putWord8 5 >> put var >> put t

128+

129+ get = do

130+ n <- getWord8

131+ case n of

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

133+ 1 -> Var <$> get

134+ 2 -> Type <$> get

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

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

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

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

compiler/AST/Variable.hsnew file+152

@@ -0,0 +1,152 @@

1+{-# OPTIONS_GHC -W #-}

2+module AST.Variable where

3+

4+import Data.Binary

5+import Control.Applicative ((<$>), (<*>))

6+import Text.PrettyPrint as P

7+import qualified AST.Helpers as Help

8+import AST.PrettyPrint

9+

10+newtype Raw = Raw String

11+ deriving (Eq,Ord,Show)

12+

13+data Home

14+ = BuiltIn

15+ | Module !String

16+ | Local

17+ deriving (Eq,Ord,Show)

18+

19+data Canonical = Canonical

20+ { home :: !Home

21+ , name :: !String

22+ } deriving (Eq,Ord,Show)

23+

24+local :: String -> Canonical

25+local x = Canonical Local x

26+

27+builtin :: String -> Canonical

28+builtin x = Canonical BuiltIn x

29+

30+-- To help with pattern matching on some common canonical variables:

31+is :: String -> String -> Canonical -> Bool

32+is home name var =

33+ var == Canonical (Module home) name

34+

35+isJson :: Canonical -> Bool

36+isJson = is "Json" "Value"

37+

38+isMaybe :: Canonical -> Bool

39+isMaybe = is "Maybe" "Maybe"

40+

41+isArray :: Canonical -> Bool

42+isArray = is "Array" "Array"

43+

44+isSignal :: Canonical -> Bool

45+isSignal = is "Signal" "Signal"

46+

47+isList :: Canonical -> Bool

48+isList v = v == Canonical BuiltIn "_List"

49+

50+isTuple :: Canonical -> Bool

51+isTuple v =

52+ case v of

53+ Canonical BuiltIn name -> Help.isTuple name

54+ _ -> False

55+

56+isPrimitive :: Canonical -> Bool

57+isPrimitive v =

58+ case v of

59+ Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]

60+ _ -> False

61+

62+isPrim :: String -> Canonical -> Bool

63+isPrim prim v =

64+ case v of

65+ Canonical BuiltIn name -> name == prim

66+ _ -> False

67+

68+isText :: Canonical -> Bool

69+isText = is "Text" "Text"

70+

71+class ToString a where

72+ toString :: a -> String

73+

74+instance ToString Raw where

75+ toString (Raw x) = x

76+

77+instance ToString Canonical where

78+ toString (Canonical home name) =

79+ case home of

80+ BuiltIn -> name

81+ Module path -> path ++ "." ++ name

82+ Local -> name

83+

84+-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)

85+data Listing a = Listing

86+ { _explicits :: [a]

87+ , _open :: Bool

88+ } deriving (Eq,Ord,Show)

89+

90+openListing :: Listing a

91+openListing = Listing [] True

92+

93+-- | A value that can be imported or exported

94+data Value

95+ = Value !String

96+ | Alias !String

97+ | ADT !String !(Listing String)

98+ deriving (Eq,Ord,Show)

99+

100+instance Pretty Raw where

101+ pretty (Raw var) = variable var

102+

103+instance Pretty Canonical where

104+ pretty var = P.text (toString var)

105+

106+instance Pretty a => Pretty (Listing a) where

107+ pretty (Listing explicits open) =

108+ P.parens (commaCat (map pretty explicits ++ dots))

109+ where

110+ dots = [if open then P.text ".." else P.empty]

111+

112+instance Pretty Value where

113+ pretty portable =

114+ case portable of

115+ Value name -> P.text name

116+ Alias name -> P.text name

117+ ADT name ctors ->

118+ P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })

119+

120+instance Binary Canonical where

121+ put (Canonical home name) =

122+ case home of

123+ BuiltIn -> putWord8 0 >> put name

124+ Module path -> putWord8 1 >> put path >> put name

125+ Local -> putWord8 2 >> put name

126+

127+ get = do tag <- getWord8

128+ case tag of

129+ 0 -> Canonical BuiltIn <$> get

130+ 1 -> Canonical . Module <$> get <*> get

131+ 2 -> Canonical Local <$> get

132+ _ -> error "Unexpected tag when deserializing canonical variable"

133+

134+instance Binary Value where

135+ put portable =

136+ case portable of

137+ Value name -> putWord8 0 >> put name

138+ Alias name -> putWord8 1 >> put name

139+ ADT name ctors -> putWord8 2 >> put name >> put ctors

140+

141+ get = do tag <- getWord8

142+ case tag of

143+ 0 -> Value <$> get

144+ 1 -> Alias <$> get

145+ 2 -> ADT <$> get <*> get

146+ _ -> error "Error reading valid import/export information from serialized string"

147+

148+instance (Binary a) => Binary (Listing a) where

149+ put (Listing explicits open) =

150+ put explicits >> put open

151+

152+ get = Listing <$> get <*> get

compiler/Build/Dependencies.hs+1−1

@@ -10,7 +10,7 @@ import qualified Data.Set as Set

10import System.Directory

11import System.FilePath as FP

12

13−import qualified SourceSyntax.Module as Module

13+import qualified AST.Module as Module

14import qualified Parse.Parse as Parse

15import qualified Elm.Internal.Paths as Path

16import qualified Elm.Internal.Name as N

compiler/Build/File.hs+15−17

@@ -23,8 +23,7 @@ import qualified Build.Source as Source

23import qualified Build.Utils as Utils

24import qualified Generate.JavaScript as JS

25import qualified Parse.Module as Parser

26−import qualified SourceSyntax.Module as M

26+import qualified AST.Module as Module

27−import qualified Transform.Canonicalize as Canonical

28

27

29-- Reader: Runtime flags, always accessible

28-- Reader: Runtime flags, always accessible

30-- Writer: Remember the last module to be accessed

29-- Writer: Remember the last module to be accessed

@@ -33,10 +32,10 @@ type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a

33type Build a = BuildT IO a

32type Build a = BuildT IO a

34

33

35-- Interfaces, remembering if something was recompiled

34-- Interfaces, remembering if something was recompiled

36−type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

35+type BInterfaces = Map.Map String (Bool, Module.Interface)

37

36

38−evalBuild :: Flag.Flags -> M.Interfaces -> Build ()

37+evalBuild :: Flag.Flags -> Module.Interfaces -> Build ()

39− -> IO (Map.Map String M.ModuleInterface, Maybe String)

38+ -> IO (Map.Map String Module.Interface, Maybe String)

40evalBuild flags interfaces build =

39evalBuild flags interfaces build =

41 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

40 do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)

42 return (fmap snd ifaces, getLast moduleNames)

41 return (fmap snd ifaces, getLast moduleNames)

@@ -45,7 +44,7 @@ evalBuild flags interfaces build =

45

44

46-- | Builds a list of files, returning the moduleName of the last one.

45-- | Builds a list of files, returning the moduleName of the last one.

47-- Returns \"\" if the list is empty

46-- Returns \"\" if the list is empty

48−build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

47+build :: Flag.Flags -> Module.Interfaces -> [FilePath] -> IO String

49build flags interfaces files =

48build flags interfaces files =

50 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

49 do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)

51 let removeTopName = Maybe.maybe id Map.delete topName

50 let removeTopName = Maybe.maybe id Map.delete topName

@@ -56,7 +55,7 @@ build flags interfaces files =

56 | null ports = return ()

55 | null ports = return ()

57 | otherwise = Print.failure msg

56 | otherwise = Print.failure msg

58 where

57 where

59− ports = M.iPorts iface

58+ ports = Module.iPorts iface

60 msg = concat

59 msg = concat

61 [ "Port Error: ports may only appear in the main module, but\n"

60 [ "Port Error: ports may only appear in the main module, but\n"

62 , " sub-module ", name, " declares the following port"

61 , " sub-module ", name, " declares the following port"

@@ -123,9 +122,7 @@ retrieve filePath = do

123 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

122 iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

124 case Interface.isValid filePath iface of

123 case Interface.isValid filePath iface of

125 Right (name, interface) ->

124 Right (name, interface) ->

126− do binterfaces <- get

127− let interfaces = snd <$> binterfaces

128− liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

125+ do liftIO $ when (Flag.print_types flags) (Print.types (Module.iTypes interface))

129 update name interface False

126 update name interface False

130

127

131 Left err -> liftIO $ Print.failure err

128 Left err -> liftIO $ Print.failure err

@@ -142,16 +139,17 @@ compile number filePath =

142 createDirectoryIfMissing True (Flag.cache_dir flags)

139 createDirectoryIfMissing True (Flag.cache_dir flags)

143 createDirectoryIfMissing True (Flag.build_dir flags)

140 createDirectoryIfMissing True (Flag.build_dir flags)

144

141

145− metaModule <-

142+ canonicalModule <-

146 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

143 liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

147 Right modul -> return modul

144 Right modul -> return modul

148 Left errors -> do Print.errors errors

145 Left errors -> do Print.errors errors

149 exitFailure

146 exitFailure

150

147

151− liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule

148+ liftIO $ when (Flag.print_types flags) $ do

149+ Print.types (Module.types (Module.body canonicalModule))

152

150

153− let newInters = Canonical.interface name $ M.metaToInterface metaModule

151+ let newInters = Module.toInterface canonicalModule

154− generateCache name newInters metaModule

152+ generateCache name newInters canonicalModule

155 update name newInters True

153 update name newInters True

156

154

157 where

155 where

@@ -164,15 +162,15 @@ compile number filePath =

164 , replicate (max 1 (20 - length name)) ' '

162 , replicate (max 1 (20 - length name)) ' '

165 , "( " ++ filePath ++ " )" ]

163 , "( " ++ filePath ++ " )" ]

166

164

167− generateCache name interfs metaModule = do

165+ generateCache name interfs canonicalModule = do

168 flags <- ask

166 flags <- ask

169 liftIO $ do

167 liftIO $ do

170 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

168 createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

171− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)

169+ writeFile (Utils.elmo flags filePath) (JS.generate canonicalModule)

172 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

170 withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

173 L.hPut handle (Binary.encode (name, interfs))

171 L.hPut handle (Binary.encode (name, interfs))

174

172

175−update :: String -> M.ModuleInterface -> Bool -> Build ()

173+update :: String -> Module.Interface -> Bool -> Build ()

176update name inter wasUpdated =

174update name inter wasUpdated =

177 do modify (Map.insert name (wasUpdated, inter))

175 do modify (Map.insert name (wasUpdated, inter))

178 tell (Last . Just $ name)

176 tell (Last . Just $ name)

compiler/Build/Flags.hs+27−11

@@ -9,6 +9,7 @@ data Flags = Flags

9 , files :: [FilePath]

10 , set_runtime :: Maybe FilePath

11 , get_runtime :: Bool

12+ , bundle_runtime :: Bool

12 , only_js :: Bool

13 , only_js :: Bool

13 , print_types :: Bool

14 , print_types :: Bool

14 , scripts :: [FilePath]

15 , scripts :: [FilePath]

@@ -18,29 +19,44 @@ data Flags = Flags

18 , src_dir :: [FilePath]

19 , src_dir :: [FilePath]

19 }

20 }

20 deriving (Data,Typeable,Show,Eq)

21 deriving (Data,Typeable,Show,Eq)

21−

22+

23+flags :: Flags

22flags = Flags

24flags = Flags

23 { files = def &= args &= typ "FILES"

25 { files = def &= args &= typ "FILES"

26+

24 , make = False

27 , make = False

25− &= help "automatically compile dependencies."

28+ &= help "automatically compile dependencies."

29+

26 , only_js = False

30 , only_js = False

27− &= help "Compile only to JavaScript."

31+ &= help "Compile only to JavaScript."

32+

28 , no_prelude = False

33 , no_prelude = False

29− &= help "Do not import Prelude by default, used only when compiling standard libraries."

34+ &= help "Do not import Prelude by default, used only when compiling standard libraries."

35+

30 , scripts = [] &= typFile

36 , scripts = [] &= typFile

31− &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

37+ &= help "Load JavaScript files in generated HTML. Files will be included in the given order."

38+

32 , set_runtime = Nothing &= typFile

39 , set_runtime = Nothing &= typFile

33− &= help "Specify a custom location for Elm's runtime system."

40+ &= help "Specify a custom location for Elm's runtime system."

41+

34 , get_runtime = False

42 , get_runtime = False

35− &= help "Print the absolute path to the default Elm runtime."

43+ &= help "Print the absolute path to the default Elm runtime."

44+

45+ , bundle_runtime = False

46+ &= help "Bundle the runtime with the generated html or js to create a standalone file."

47+

36 , cache_dir = "cache" &= typFile

48 , cache_dir = "cache" &= typFile

37− &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

49+ &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

50+

38 , build_dir = "build" &= typFile

51 , build_dir = "build" &= typFile

39− &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

52+ &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

53+

40 , src_dir = ["."] &= typFile

54 , src_dir = ["."] &= typFile

41− &= help "Additional source directories besides project root. Searched when using --make"

55+ &= help "Additional source directories besides project root. Searched when using --make"

56+

42 , print_types = False

57 , print_types = False

43− &= help "Print out inferred types of top-level definitions."

58+ &= help "Print out inferred types of top-level definitions."

59+

44 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

60 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

45 &= helpArg [explicit, name "help", name "h"]

61 &= helpArg [explicit, name "help", name "h"]

46 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]

62 &= versionArg [explicit, name "version", name "v", summary (show Version.elmVersion)]

compiler/Build/Interface.hs+2−2

@@ -7,7 +7,7 @@ import qualified Data.Binary as Binary

7import qualified Build.Print as Print

8import qualified Elm.Internal.Version as Version

9import System.Directory (doesFileExist)

10−import SourceSyntax.Module

10+import AST.Module as Module

11

12load :: Binary.Binary a => FilePath -> IO a

13load filePath =

@@ -28,7 +28,7 @@ load filePath =

28 , " Please remove the file and try again."

29 ]

30

31−isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)

31+isValid :: FilePath -> (String, Module.Interface) -> Either String (String, Module.Interface)

32isValid filePath (name, interface) =

33 let version = iVersion interface in

34 if version == Version.elmVersion

compiler/Build/Print.hs+7−25

@@ -5,42 +5,24 @@ import System.Exit (exitFailure)

5

6import qualified Data.Map as Map

7import qualified Data.List as List

8−import qualified SourceSyntax.Type as T

8+import qualified AST.Module as Module

9−import qualified SourceSyntax.Module as M

10−import qualified SourceSyntax.PrettyPrint as Pretty

9+import qualified AST.PrettyPrint as Pretty

11−import qualified Type.Alias as Alias

12import qualified Text.PrettyPrint as P

10import qualified Text.PrettyPrint as P

13

11

14−metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()

12+types :: Module.Types -> IO ()

15−metaTypes interfaces meta =

13+types ts =

16− types interfaces (M.types meta) (M.aliases meta) (M.imports meta)

17−

18−interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()

19−interfaceTypes interfaces iface =

20− types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)

21−

22−types :: Map.Map k M.ModuleInterface

23− -> Map.Map String T.Type

24− -> [M.Alias]

25− -> [(String, M.ImportMethod)]

26− -> IO ()

27−types interfaces types' aliases imports =

28 do putStrLn ""

14 do putStrLn ""

29− mapM_ printType (Map.toList types')

15+ mapM_ printType (Map.toList ts)

30 putStrLn ""

16 putStrLn ""

31 where

17 where

32− rules = Alias.rules interfaces aliases imports

33−

34 printType (n,t) = do

18 printType (n,t) = do

35 print $ P.hsep [ Pretty.variable n

19 print $ P.hsep [ Pretty.variable n

36 , P.text ":"

20 , P.text ":"

37− , Pretty.pretty (Alias.realias rules t) ]

21+ , Pretty.pretty t ]

38

22

39errors :: [P.Doc] -> IO ()

23errors :: [P.Doc] -> IO ()

40errors errs =

24errors errs =

41 mapM_ print (List.intersperse (P.text " ") errs)

25 mapM_ print (List.intersperse (P.text " ") errs)

42

26

43failure :: String -> IO a

27failure :: String -> IO a

44−failure msg =

45− do hPutStrLn stderr msg

28+failure msg = hPutStrLn stderr msg >> exitFailure

46− exitFailure

compiler/Build/Source.hs+21−43

@@ -2,57 +2,35 @@

2module Build.Source (build) where

3

4import qualified Data.Map as Map

5−import System.FilePath as FP

6import Text.PrettyPrint (Doc)

5import Text.PrettyPrint (Doc)

7

6

8−import SourceSyntax.Declaration

7+import AST.Module as Module

9−import SourceSyntax.Module

10−import qualified SourceSyntax.Expression as Expr

11−import qualified SourceSyntax.Pattern as Pattern

12−import qualified SourceSyntax.Type as Type

13import qualified Parse.Parse as Parse

8import qualified Parse.Parse as Parse

14import qualified Metadata.Prelude as Prelude

9import qualified Metadata.Prelude as Prelude

15import qualified Transform.Check as Check

10import qualified Transform.Check as Check

16−import qualified Transform.SortDefinitions as SD

17import qualified Type.Inference as TI

11import qualified Type.Inference as TI

18−import qualified Type.Constrain.Declaration as TcDecl

19import qualified Transform.Canonicalize as Canonical

12import qualified Transform.Canonicalize as Canonical

20

13

21−build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule

14+build :: Bool -> Interfaces -> String -> Either [Doc] CanonicalModule

22build noPrelude interfaces source =

15build noPrelude interfaces source =

23− do let add = Prelude.add noPrelude

24− infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

16+ do let infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

25 . concatMap iFixities $ Map.elems interfaces

17 . concatMap iFixities $ Map.elems interfaces

26

18

27− Module names exs ims decls <- do

19+ -- Parse the source code and validate that it is well formed.

20+ validModule <- do

28− modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source

21+ modul <- Prelude.add noPrelude `fmap` Parse.program infixes source

29− case Check.mistakes decls of

22+ case Check.mistakes (body modul) of

30− [] -> return modul

23+ [] -> return modul

31− ms -> Left ms

24+ ms -> Left ms

32−

25+

33− let exports'

26+ -- Canonicalize all variables, pinning down where they came from.

34− | null exs =

35− let get = Pattern.boundVarList in

36− concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++

37− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

38− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

39− | otherwise = exs

40−

41− metaModule <- Canonical.metadataModule interfaces $

27+ canonicalModule <- Canonical.module' interfaces validModule

42− MetadataModule

28+

43− { names = names

29+ -- Run type inference on the program.

44− , path = FP.joinPath names

45− , exports = exports'

46− , imports = ims

47− -- reorder AST into strongly connected components

48− , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls

49− , types = Map.empty

50− , datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ]

51− , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]

52− , aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ]

53− , ports = [ portName port | Port port <- decls ]

54− }

55−

56− types <- TI.infer interfaces metaModule

30+ types <- TI.infer interfaces canonicalModule

57−

31+

58− return $ metaModule { types = types }

32+ -- Trim down the set of exported values to the stuff that is actually exported.

33+ let types' = Canonical.filterExports types (Module.exports canonicalModule)

34+ body' = (body canonicalModule) { types = types' }

35+

36+ return $ canonicalModule { body = body' }

compiler/Compiler.hs+28−12

@@ -25,12 +25,12 @@ main = do setNumCapabilities =<< getNumProcessors

25

26compileArgs :: Flag.Flags -> IO ()

27compileArgs flags =

28− do when (Flag.get_runtime flags) $

28+ do when (Flag.get_runtime flags) $ do

29− do putStrLn Path.runtime

29+ putStrLn Path.runtime

30− exitSuccess

30+ exitSuccess

31 case Flag.files flags of

32− [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"

32+ [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"

33− fs -> mapM_ (build flags) fs

33+ fs -> mapM_ (build flags) fs

34

35build :: Flag.Flags -> FilePath -> IO ()

36build flags rootFile =

@@ -50,9 +50,9 @@ build flags rootFile =

50 (extension, code) <-

51 if Flag.only_js flags

52 then do putStr "Generating JavaScript ... "

53− return ("js", js)

53+ makeJs js

54 else do putStr "Generating HTML ... "

55− return (makeHtml js moduleName)

55+ makeHtml js moduleName

56

57 let targetFile = Utils.buildPath flags rootFile extension

58 createDirectoryIfMissing True (takeDirectory targetFile)

@@ -65,9 +65,25 @@ build flags rootFile =

65 src <- BS.readFile filePath

66 return (BS.append src js)

67

68− sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]

68+ getRuntime :: IO Html.JSSource

69+ getRuntime =

70+ let runtimePath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags) in

71+ case Flag.bundle_runtime flags of

72+ False -> return (Html.Link runtimePath)

73+ True -> Html.Source `fmap` BS.readFile runtimePath

69

74

75+ makeJs :: BS.ByteString -> IO (String, BS.ByteString)

76+ makeJs js =

77+ do runtime <- getRuntime

78+ case runtime of

79+ Html.Link _ -> return ("js", js)

80+ Html.Source rts -> return ("js", BS.append rts js)

81+

82+ makeHtml :: BS.ByteString -> String -> IO (String, BS.ByteString)

83+ makeHtml js moduleName =

84+ do runtime <- getRuntime

70− makeHtml js moduleName = ("html", BS.pack $ renderHtml html)

85+ return ("html", BS.pack $ renderHtml (html runtime))

71− where

86+ where

72− rtsPath = Maybe.fromMaybe Path.runtime (Flag.set_runtime flags)

87+ sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]

88+ html runtime =

73− html = Html.generate rtsPath (takeBaseName rootFile) (sources js) moduleName ""

89+ Html.generate runtime (takeBaseName rootFile) (sources js) moduleName ""

compiler/Docs.hs+29−19

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

2{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

2module Main where

3module Main where

3

4

@@ -16,10 +17,11 @@ import qualified Data.Map as Map

16import qualified Data.ByteString.Lazy as BS

17import qualified Data.ByteString.Lazy as BS

17import qualified Data.Text as Text

18import qualified Data.Text as Text

18

19

19−import qualified SourceSyntax.Helpers as Help

20+import qualified AST.Helpers as Help

20−import qualified SourceSyntax.Type as T

21+import qualified AST.Type as T

21−import qualified SourceSyntax.Expression as E

22+import qualified AST.Declaration as D

22−import qualified SourceSyntax.Declaration as D

23+import qualified AST.Expression.Source as Src

24+import qualified AST.Variable as Var

23

25

24import Text.Parsec hiding (newline,spaces)

26import Text.Parsec hiding (newline,spaces)

25import Parse.Declaration (alias,datatype,infixDecl)

27import Parse.Declaration (alias,datatype,infixDecl)

@@ -74,7 +76,7 @@ docComment = do

74 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

76 let reversed = dropWhile (`elem` " \n\r") . drop 2 $ reverse contents

75 return $ dropWhile (==' ') (reverse reversed)

77 return $ dropWhile (==' ') (reverse reversed)

76

78

77−moduleDocs :: IParser (String, [String], String)

79+--moduleDocs :: IParser (String, [String], String)

78moduleDocs = do

80moduleDocs = do

79 optional freshLine

81 optional freshLine

80 (names,exports) <- moduleDef

82 (names,exports) <- moduleDef

@@ -83,10 +85,10 @@ moduleDocs = do

83 structure <- docComment

85 structure <- docComment

84 return (List.intercalate "." names, exports, structure)

86 return (List.intercalate "." names, exports, structure)

85

87

86−document :: IParser [(String, D.ParseDeclaration, String)]

88+--document :: IParser [(String, D.SourceDecl, String)]

87document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

89document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

88

90

89−docThing :: IParser (String, D.ParseDeclaration, String)

91+--docThing :: IParser (String, D.SourceDecl, String)

90docThing = uncommentable <|> commented <|> uncommented ""

92docThing = uncommentable <|> commented <|> uncommented ""

91 where

93 where

92 uncommentable = do

94 uncommentable = do

@@ -106,10 +108,11 @@ docThing = uncommentable <|> commented <|> uncommented ""

106documentToJson name exports structure things =

108documentToJson name exports structure things =

107 object $ [ "name" .= name

109 object $ [ "name" .= name

108 , "document" .= structure

110 , "document" .= structure

109− , "values" .= toList values

111+-- , "values" .= toList values

110− , "aliases" .= toList aliases

112+-- , "aliases" .= toList aliases

111− , "datatypes" .= toList adts

113+-- , "datatypes" .= toList adts

112 ]

114 ]

115+{--

113 where

116 where

114 (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things

117 (values, aliases, adts) = collect Map.empty Map.empty Map.empty Map.empty things

115

118

@@ -120,7 +123,8 @@ documentToJson name exports structure things =

120 case Map.null exportMap of

123 case Map.null exportMap of

121 True -> dict

124 True -> dict

122 False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict

125 False -> Map.filterWithKey (\k _ -> Map.member k exportMap) dict

123−

126+--}

127+{--

124collect infixes types aliases adts things =

128collect infixes types aliases adts things =

125 case things of

129 case things of

126 [] -> (Map.union customOps nonCustomOps, aliases, adts)

130 [] -> (Map.union customOps nonCustomOps, aliases, adts)

@@ -138,13 +142,13 @@ collect infixes types aliases adts things =

138 case decl of

142 case decl of

139 D.Fixity assoc prec name ->

143 D.Fixity assoc prec name ->

140 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

144 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

141− D.Definition (E.TypeAnnotation name tipe) ->

145+ D.Definition (Src.TypeAnnotation name tipe) ->

142 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

146 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

143 D.TypeAlias name vars tipe ->

147 D.TypeAlias name vars tipe ->

144 let fields = ["typeVariables" .= vars, "type" .= tipe ]

148 let fields = ["typeVariables" .= vars, "type" .= tipe ]

145 in collect infixes types (insert name fields aliases) adts rest

149 in collect infixes types (insert name fields aliases) adts rest

146 D.Datatype name vars ctors ->

150 D.Datatype name vars ctors ->

147− let tipe = T.Data name (map T.Var vars)

151+ let tipe = T.App (T.Type name) (map T.Var vars)

148 fields = ["typeVariables" .= vars

152 fields = ["typeVariables" .= vars

149 , "constructors" .= map (ctorToJson tipe) ctors ]

153 , "constructors" .= map (ctorToJson tipe) ctors ]

150 in collect infixes types aliases (insert name fields adts) rest

154 in collect infixes types aliases (insert name fields adts) rest

@@ -152,8 +156,8 @@ collect infixes types aliases adts things =

152 insert name fields dict = Map.insert name (obj name fields) dict

156 insert name fields dict = Map.insert name (obj name fields) dict

153 obj name fields =

157 obj name fields =

154 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields

158 [ "name" .= name, "raw" .= source, "comment" .= comment ] ++ fields

155−

159+--}

156−instance ToJSON T.Type where

160+instance Var.ToString var => ToJSON (T.Type var) where

157 toJSON tipe =

161 toJSON tipe =

158 object $

162 object $

159 case tipe of

163 case tipe of

@@ -168,10 +172,16 @@ instance ToJSON T.Type where

168 [ "tag" .= ("var" :: Text.Text)

172 [ "tag" .= ("var" :: Text.Text)

169 , "name" .= toJSON x

173 , "name" .= toJSON x

170 ]

174 ]

171−

175+

176+ T.Type name ->

177+ [ "tag" .= ("adt" :: Text.Text)

178+ , "name" .= toJSON (Var.toString name)

179+ , "args" .= ([] :: [()])

180+ ]

181+

172− T.Data name ts ->

182+ T.App (T.Type name) ts ->

173 [ "tag" .= ("adt" :: Text.Text)

183 [ "tag" .= ("adt" :: Text.Text)

174− , "name" .= toJSON name

184+ , "name" .= toJSON (Var.toString name)

175 , "args" .= map toJSON ts

185 , "args" .= map toJSON ts

176 ]

186 ]

177

187

@@ -181,7 +191,7 @@ instance ToJSON T.Type where

181 , "extension" .= toJSON ext

191 , "extension" .= toJSON ext

182 ]

192 ]

183

193

184−ctorToJson :: T.Type -> (String, [T.Type]) -> Value

194+ctorToJson :: Var.ToString var => T.Type var -> (String, [T.Type var]) -> Value

185ctorToJson tipe (ctor, tipes) =

195ctorToJson tipe (ctor, tipes) =

186 object [ "name" .= ctor

196 object [ "name" .= ctor

187 , "type" .= foldr T.Lambda tipe tipes ]

197 , "type" .= foldr T.Lambda tipe tipes ]

compiler/Dummy.cabal+220−99

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

1−-- This is a dummy .cabal file that makes it possible to build the

2−-- compiler with GHCi from within emacs. Do not actually use this

3−-- file to install things.

4−

5Name: Elm

1Name: Elm

6−Version: 0.8.0.3

2+Version: 0.12

7Synopsis: The Elm language module.

3Synopsis: The Elm language module.

8Description: Elm aims to make client-side web-development more pleasant.

4Description: Elm aims to make client-side web-development more pleasant.

9 It is a statically/strongly typed, functional reactive

5 It is a statically/strongly typed, functional reactive

@@ -18,153 +14,278 @@ License-file: LICENSE

18

14

19Author: Evan Czaplicki

15Author: Evan Czaplicki

20Maintainer: info@elm-lang.org

16Maintainer: info@elm-lang.org

22

18

23Category: Compiler, Language

19Category: Compiler, Language

24

20

25Build-type: Custom

21Build-type: Custom

26

22

27−Extra-source-files: changelog.txt

23+Extra-source-files: changelog.md

28−Data-dir: dist/data

24+Data-dir: data

29−Data-files: elm-runtime.js docs.json

25+Data-files: elm-runtime.js interfaces.data docs.json

30−Cabal-version: >=1.8

26+Cabal-version: >=1.9

31

27

32source-repository head

28source-repository head

33 type: git

29 type: git

34 location: git://github.com/evancz/Elm.git

30 location: git://github.com/evancz/Elm.git

35

31

36Library

32Library

37− exposed-modules: Language.Elm,

33+ exposed-modules: Elm.Internal.Dependencies,

38− Language.Elm.Quasi

34+ Elm.Internal.Documentation,

35+ Elm.Internal.Name,

36+ Elm.Internal.Paths,

37+ Elm.Internal.Utils,

38+ Elm.Internal.Version

39 Hs-Source-Dirs: compiler

40− other-modules: Unique,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

41− SourceSyntax.Helpers,

46+ AST.Helpers,

42− SourceSyntax.Location,

43− SourceSyntax.Literal,

47+ AST.Literal,

48+ AST.Module,

44− SourceSyntax.Pattern,

49+ AST.Pattern,

45− SourceSyntax.Expression,

50+ AST.PrettyPrint,

46− SourceSyntax.Declaration,

51+ AST.Type,

47− SourceSyntax.Module,

52+ AST.Variable,

48 Generate.JavaScript,

53 Generate.JavaScript,

49− Generate.Noscript,

54+ Generate.JavaScript.Helpers,

55+ Generate.JavaScript.Ports,

56+ Generate.Markdown,

50 Generate.Html,

57 Generate.Html,

51 Generate.Cases,

58 Generate.Cases,

59+ Transform.Canonicalize,

60+ Transform.Check,

61+ Transform.Expression,

62+ Transform.Declaration,

63+ Transform.Definition,

64+ Transform.SortDefinitions,

52 Transform.Substitute,

65 Transform.Substitute,

53− Transform.Optimize,

54− Metadata.Libraries,

66+ Metadata.Prelude,

55− Metadata.LoadLibraries,

56− Initialize,

57 Parse.Binop,

67 Parse.Binop,

68+ Parse.Declaration,

58 Parse.Expression,

69 Parse.Expression,

59− Parse.Foreign,

60 Parse.Helpers,

70 Parse.Helpers,

71+ Parse.Literal,

61 Parse.Module,

72 Parse.Module,

62− Parse.Parser,

73+ Parse.Parse,

63 Parse.Pattern,

74 Parse.Pattern,

64 Parse.Type,

75 Parse.Type,

65− Types.Alias,

76+ Type.Alias,

66− Types.Types,

77+ Type.Constrain.Expression,

78+ Type.Constrain.Literal,

67− Types.Constrain,

79+ Type.Constrain.Pattern,

68− Types.Hints,

80+ Type.Environment,

69− Types.Solver,

81+ Type.ExtraChecks,

70− Types.Substitutions,

82+ Type.Fragment,

83+ Type.Inference,

84+ Type.PrettyPrint,

85+ Type.Solve,

86+ Type.State,

87+ Type.Type,

71− Types.Unify,

88+ Type.Unify,

89+ Build.Dependencies,

90+ Build.File,

91+ Build.Flags,

92+ Build.Interface,

93+ Build.Print,

94+ Build.Source,

95+ Build.Utils,

72 Paths_Elm

96 Paths_Elm

73

97

74− Build-depends: base >=4.2 && <5,

98+ Build-depends: aeson,

99+ base >=4.2 && <5,

100+ binary >= 0.7.0.0,

101+ blaze-html >= 0.5 && < 0.8,

102+ blaze-markup,

103+ bytestring,

104+ cmdargs,

75 containers >= 0.3,

105 containers >= 0.3,

76− transformers >= 0.2,

106+ directory,

107+ filepath,

108+ indents,

109+ language-ecmascript >=0.15 && < 1.0,

110+ language-glsl,

77 mtl >= 2,

111 mtl >= 2,

78− deepseq,

112+ pandoc >= 1.10,

79 parsec >= 3.1.1,

113 parsec >= 3.1.1,

80− blaze-html == 0.5.* || == 0.6.*,

114+ pretty,

81− blaze-markup == 0.5.1.*,

82 text,

115 text,

83− shakespeare >= 1,

116+ transformers >= 0.2,

84− template-haskell,

117+ union-find,

85− pandoc >= 1.10,

118+ unordered-containers

86− bytestring,

87− uniplate,

88− hjsmin,

89− indents,

90− filepath,

91− json,

92− directory

93

119

94Executable elm

120Executable elm

95 Main-is: Compiler.hs

121 Main-is: Compiler.hs

122+ ghc-options: -threaded -O2

96 Hs-Source-Dirs: compiler

123 Hs-Source-Dirs: compiler

97− other-modules: Unique,

124+ other-modules: AST.Annotation,

125+ AST.Declaration,

126+ AST.Expression.General,

127+ AST.Expression.Source,

128+ AST.Expression.Valid,

129+ AST.Expression.Canonical,

98− SourceSyntax.Helpers,

130+ AST.Helpers,

99− SourceSyntax.Location,

100− SourceSyntax.Literal,

131+ AST.Literal,

132+ AST.Module,

101− SourceSyntax.Pattern,

133+ AST.Pattern,

102− SourceSyntax.Expression,

134+ AST.PrettyPrint,

103− SourceSyntax.Declaration,

135+ AST.Type,

104− SourceSyntax.Module,

136+ AST.Variable,

105 Generate.JavaScript,

137 Generate.JavaScript,

106− Generate.Noscript,

138+ Generate.JavaScript.Helpers,

139+ Generate.JavaScript.Ports,

140+ Generate.Markdown,

107 Generate.Html,

141 Generate.Html,

108 Generate.Cases,

142 Generate.Cases,

143+ Transform.Canonicalize,

144+ Transform.Check,

145+ Transform.Expression,

146+ Transform.Declaration,

147+ Transform.Definition,

148+ Transform.SortDefinitions,

109 Transform.Substitute,

149 Transform.Substitute,

110− Transform.Optimize,

111− Metadata.Libraries,

150+ Metadata.Prelude,

112− Metadata.LoadLibraries,

113− Initialize,

114 Parse.Binop,

151 Parse.Binop,

152+ Parse.Declaration,

115 Parse.Expression,

153 Parse.Expression,

116− Parse.Foreign,

117 Parse.Helpers,

154 Parse.Helpers,

155+ Parse.Literal,

118 Parse.Module,

156 Parse.Module,

119− Parse.Parser,

157+ Parse.Parse,

120 Parse.Pattern,

158 Parse.Pattern,

121 Parse.Type,

159 Parse.Type,

122− Types.Alias,

160+ Type.Alias,

123− Types.Types,

161+ Type.Constrain.Expression,

162+ Type.Constrain.Literal,

124− Types.Constrain,

163+ Type.Constrain.Pattern,

125− Types.Hints,

164+ Type.Environment,

126− Types.Solver,

165+ Type.ExtraChecks,

127− Types.Substitutions,

166+ Type.Fragment,

167+ Type.Inference,

168+ Type.PrettyPrint,

169+ Type.Solve,

170+ Type.State,

171+ Type.Type,

128− Types.Unify,

172+ Type.Unify,

173+ Build.Dependencies,

174+ Build.File,

175+ Build.Flags,

176+ Build.Interface,

177+ Build.Print,

178+ Build.Source,

179+ Build.Utils,

129 Paths_Elm

180 Paths_Elm

130

181

131− Build-depends: base >=4.2 && <5,

182+ Build-depends: aeson,

183+ base >=4.2 && <5,

184+ binary >= 0.7.0.0,

185+ blaze-html >= 0.5 && < 0.8,

186+ blaze-markup,

187+ bytestring,

188+ cmdargs,

132 containers >= 0.3,

189 containers >= 0.3,

133− transformers >= 0.2,

190+ directory,

191+ filepath,

192+ indents,

193+ language-ecmascript >=0.15 && < 1.0,

194+ language-glsl,

134 mtl >= 2,

195 mtl >= 2,

135− deepseq,

136− parsec >= 3.1.1,

137− blaze-html == 0.5.* || == 0.6.*,

138− blaze-markup == 0.5.1.*,

139− cmdargs,

140 pandoc >= 1.10,

196 pandoc >= 1.10,

141− bytestring,

197+ parsec >= 3.1.1,

142− uniplate,

198+ pretty,

143− hjsmin,

199+ text,

144− indents,

200+ transformers >= 0.2,

145− filepath,

201+ union-find,

146− json,

202+ unordered-containers

147− directory

148

203

149Executable elm-doc

204Executable elm-doc

150 Main-is: Docs.hs

205 Main-is: Docs.hs

151 Hs-Source-Dirs: compiler

206 Hs-Source-Dirs: compiler

152− other-modules: SourceSyntax.Helpers,

207+ other-modules: AST.Annotation,

153− SourceSyntax.Location,

208+ AST.Declaration,

209+ AST.Expression.General,

210+ AST.Helpers,

154− SourceSyntax.Literal,

211+ AST.Literal,

155− SourceSyntax.Pattern,

156− SourceSyntax.Expression,

157− SourceSyntax.Declaration,

158− SourceSyntax.Module,

212+ AST.Module,

213+ AST.Pattern,

214+ AST.PrettyPrint,

215+ AST.Type,

216+ AST.Variable,

217+ Parse.Binop,

218+ Parse.Declaration,

219+ Parse.Expression,

159 Parse.Helpers,

220 Parse.Helpers,

221+ Parse.Literal,

160− Parse.Module

222+ Parse.Module,

223+ Parse.Pattern,

224+ Parse.Type

161

225

162− Build-depends: base >=4.2 && <5,

226+ Build-depends: aeson,

227+ aeson-pretty,

228+ base >=4.2 && <5,

229+ binary >= 0.7.0.0,

230+ bytestring,

231+ cmdargs,

163 containers >= 0.3,

232 containers >= 0.3,

164− transformers >= 0.2,

233+ directory,

234+ filepath,

235+ indents,

236+ language-glsl,

165 mtl >= 2,

237 mtl >= 2,

166− parsec >= 3.1.1,

167 pandoc >= 1.10,

238 pandoc >= 1.10,

239+ parsec >= 3.1.1,

240+ pretty,

241+ text,

242+ union-find

243+

244+Test-Suite compiler-tests

245+ Type: exitcode-stdio-1.0

246+ Hs-Source-Dirs: tests/hs, compiler

247+ Main-is: CompilerTest.hs

248+ other-modules: Tests.Compiler

249+ Tests.Property

250+ Tests.Property.Arbitrary

251+ AST.Helpers

252+ AST.Literal

253+ AST.PrettyPrint

254+ build-depends: test-framework,

255+ test-framework-hunit,

256+ test-framework-quickcheck2 >= 0.3,

257+ HUnit,

258+ QuickCheck >= 2 && < 3,

259+ aeson,

260+ base >=4.2 && <5,

261+ binary >= 0.7.0.0,

262+ blaze-html == 0.5.* || == 0.6.*,

263+ blaze-markup == 0.5.1.*,

264+ bytestring,

168− cmdargs,

265+ cmdargs,

266+ containers >= 0.3,

267+ directory,

268+ Elm,

269+ filemanip,

169− filepath,

270+ filepath,

170− indents

271+ indents,

272+ language-ecmascript >=0.15 && < 1.0,

273+ language-glsl,

274+ mtl >= 2,

275+ pandoc >= 1.10,

276+ parsec >= 3.1.1,

277+ pretty,

278+ text,

279+ transformers >= 0.2,

280+ union-find,

281+ unordered-containers

282+

283+Test-Suite lib-tests

284+ Type: exitcode-stdio-1.0

285+ Hs-Source-Dirs: tests/hs

286+ Main-is: LibTest.hs

287+ build-depends: base,

288+ directory,

289+ Elm,

290+ filepath,

291+ process >= 1.2

compiler/Elm/Internal/Utils.hs+3−3

@@ -5,9 +5,9 @@ module Elm.Internal.Utils (compile, moduleName, nameAndImports) where

5import qualified Data.List as List

6import qualified Generate.JavaScript as JS

7import qualified Build.Source as Source

8−import Parse.Module (getModuleName)

8+import qualified Parse.Module as Parser

9+import qualified AST.Module as M

9import Parse.Parse (dependencies)

10import Parse.Parse (dependencies)

10−import qualified SourceSyntax.Module as M

11import qualified Text.PrettyPrint as P

12import qualified Metadata.Prelude as Prelude

13import System.IO.Unsafe

@@ -26,7 +26,7 @@ interfaces = unsafePerformIO $ Prelude.interfaces False

26

27-- |This function extracts the module name of a given source program.

28moduleName :: String -> Maybe String

29−moduleName = getModuleName

29+moduleName = Parser.getModuleName

30

31-- |This function extracts the module name and imported modules from a given

32-- source program.

compiler/Generate/Cases.hs+41−20

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2

3

3import Control.Applicative ((<$>))

4import Control.Applicative ((<$>))

@@ -6,14 +7,15 @@ import Control.Monad.State

6import Data.List (groupBy,sortBy)

7import Data.List (groupBy,sortBy)

7import Data.Maybe (fromMaybe)

8import Data.Maybe (fromMaybe)

8

9

9−import SourceSyntax.Annotation

10+import AST.Annotation

10−import SourceSyntax.Expression

11+import AST.Expression.General

12+import AST.Expression.Canonical as Canonical

11−import SourceSyntax.Literal

13+import AST.Literal

12−import qualified SourceSyntax.Pattern as P

14+import qualified AST.Pattern as P

13−import qualified SourceSyntax.Variable as V

15+import qualified AST.Variable as Var

14import Transform.Substitute

16import Transform.Substitute

15

17

16−toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)

18+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

17toMatch patterns = do

19toMatch patterns = do

18 v <- newVar

20 v <- newVar

19 (,) v <$> match [v] (map (first (:[])) patterns) Fail

21 (,) v <$> match [v] (map (first (:[])) patterns) Fail

@@ -27,12 +29,12 @@ data Match

27 = Match String [Clause] Match

29 = Match String [Clause] Match

28 | Break

30 | Break

29 | Fail

31 | Fail

30− | Other Expr

32+ | Other Canonical.Expr

31 | Seq [Match]

33 | Seq [Match]

32 deriving Show

34 deriving Show

33

35

34data Clause =

36data Clause =

35− Clause (Either String Literal) [String] Match

37+ Clause (Either Var.Canonical Literal) [String] Match

36 deriving Show

38 deriving Show

37

39

38matchSubst :: [(String,String)] -> Match -> Match

40matchSubst :: [(String,String)] -> Match -> Match

@@ -42,7 +44,7 @@ matchSubst pairs match =

42 Fail -> Fail

44 Fail -> Fail

43 Seq ms -> Seq (map (matchSubst pairs) ms)

45 Seq ms -> Seq (map (matchSubst pairs) ms)

44 Other (A a e) ->

46 Other (A a e) ->

45− Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs

47+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (localVar y)) pairs

46 Match n cs m ->

48 Match n cs m ->

47 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

49 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

48 where

50 where

@@ -50,15 +52,18 @@ matchSubst pairs match =

50 clauseSubst (Clause c vs m) =

52 clauseSubst (Clause c vs m) =

51 Clause c (map varSubst vs) (matchSubst pairs m)

53 Clause c (map varSubst vs) (matchSubst pairs m)

52

54

55+isCon :: ([P.Pattern var], expr) -> Bool

56+isCon ([] , _) = noMatch "isCon"

53isCon (p:_, _) =

57isCon (p:_, _) =

54 case p of

58 case p of

55 P.Data _ _ -> True

59 P.Data _ _ -> True

56 P.Literal _ -> True

60 P.Literal _ -> True

57 _ -> False

61 _ -> False

58

62

63+isVar :: ([P.Pattern var], expr) -> Bool

59isVar p = not (isCon p)

64isVar p = not (isCon p)

60

65

61−match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

66+match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

62match [] [] def = return def

67match [] [] def = return def

63match [] [([],e)] Fail = return $ Other e

68match [] [([],e)] Fail = return $ Other e

64match [] [([],e)] Break = return $ Other e

69match [] [([],e)] Break = return $ Other e

@@ -70,25 +75,30 @@ match vs@(v:_) cs def

70 where

75 where

71 cs' = map (dealias v) cs

76 cs' = map (dealias v) cs

72

77

73−dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)

78+dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)

79+dealias _ ([], _) = noMatch "dealias"

74dealias v c@(p:ps, A a e) =

80dealias v c@(p:ps, A a e) =

75 case p of

81 case p of

76− P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)

82+ P.Alias x pattern -> (pattern:ps, A a $ subst x (localVar v) e)

77 _ -> c

83 _ -> c

78

84

79−matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

85+matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

86+matchVar [] _ _ = noMatch "matchVar"

80matchVar (v:vs) cs def = match vs (map subVar cs) def

87matchVar (v:vs) cs def = match vs (map subVar cs) def

81 where

88 where

89+ subVar ([], _) = noMatch "matchVar.subVar"

82 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

90 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

83 where

91 where

84 subOnePattern pattern e =

92 subOnePattern pattern e =

85 case pattern of

93 case pattern of

86− P.Var x -> subst x (rawVar v) e

94+ P.Var x -> subst x (localVar v) e

87 P.Anything -> e

95 P.Anything -> e

88 P.Record fs ->

96 P.Record fs ->

89− foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs

97+ foldr (\x -> subst x (Access (A a (localVar v)) x)) e fs

98+ _ -> noMatch "matchVar.subVar"

90

99

91−matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

100+matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

101+matchCon [] _ _ = noMatch "matchCon"

92matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

102matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

93 where

103 where

94 css = groupBy eq (sortBy cmp cs)

104 css = groupBy eq (sortBy cmp cs)

@@ -97,37 +107,48 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

97 case (p1,p2) of

107 case (p1,p2) of

98 (P.Data n1 _, P.Data n2 _) -> compare n1 n2

108 (P.Data n1 _, P.Data n2 _) -> compare n1 n2

99 _ -> compare p1 p2

109 _ -> compare p1 p2

110+ cmp _ _ = noMatch "matchCon.cmp"

100

111

101 eq (p1:_,_) (p2:_,_) =

112 eq (p1:_,_) (p2:_,_) =

102 case (p1,p2) of

113 case (p1,p2) of

103 (P.Data n1 _, P.Data n2 _) -> n1 == n2

114 (P.Data n1 _, P.Data n2 _) -> n1 == n2

104 _ -> p1 == p2

115 _ -> p1 == p2

116+ eq _ _ = noMatch "matchCon.eq"

105

117

106 toClause cs =

118 toClause cs =

107 case head cs of

119 case head cs of

108 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

120 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

109 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

121 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

122+ _ -> noMatch "matchCon"

110

123

111−matchClause :: Either String Literal

124+matchClause :: Either Var.Canonical Literal

112 -> [String]

125 -> [String]

113− -> [([P.Pattern],Expr)]

126+ -> [([P.CanonicalPattern], Canonical.Expr)]

114 -> Match

127 -> Match

115 -> State Int Clause

128 -> State Int Clause

129+matchClause _ [] _ _ = noMatch "matchClause"

116matchClause c (_:vs) cs def =

130matchClause c (_:vs) cs def =

117 do vs' <- getVars

131 do vs' <- getVars

118 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

132 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

119 where

133 where

120−

134+ flatten ([], _) = noMatch "matchClause.flatten"

121 flatten (p:ps, e) =

135 flatten (p:ps, e) =

122 case p of

136 case p of

123 P.Data _ ps' -> (ps' ++ ps, e)

137 P.Data _ ps' -> (ps' ++ ps, e)

124 P.Literal _ -> (ps, e)

138 P.Literal _ -> (ps, e)

139+ _ -> noMatch "matchClause.flatten"

125

140

126 getVars =

141 getVars =

127 case head cs of

142 case head cs of

128 (P.Data _ ps : _, _) -> forM ps (const newVar)

143 (P.Data _ ps : _, _) -> forM ps (const newVar)

129 (P.Literal _ : _, _) -> return []

144 (P.Literal _ : _, _) -> return []

145+ _ -> noMatch "matchClause.getVars"

130

146

131−matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

147+matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

132matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

148matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

133 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

149 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

150+

151+noMatch :: String -> a

152+noMatch name =

153+ error $ "unexpected pattern in '" ++ name ++

154+ "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

compiler/Generate/Html.hs+3−3

@@ -17,13 +17,13 @@ makeScript source =

17 H.script ! A.type_ "text/javascript" $

18 preEscapedToMarkup $ BS.unpack src

19

20−generate :: FilePath -> String -> [JSSource] -> String -> String -> H.Html

20+generate :: JSSource -> String -> [JSSource] -> String -> String -> H.Html

21−generate libLoc title scripts moduleName noscript =

21+generate runtime title scripts moduleName noscript =

22 H.docTypeHtml $ do

23 H.head $ do

24 H.meta ! A.charset "UTF-8"

25 H.title . H.toHtml $ title

26− makeScript (Link libLoc)

26+ makeScript runtime

27 mapM_ makeScript scripts

28 H.body $ do

29 H.script ! A.type_ "text/javascript" $

compiler/Generate/JavaScript.hs+152−118

@@ -10,59 +10,66 @@ import qualified Data.Set as Set

10import Language.ECMAScript3.PrettyPrint

11import Language.ECMAScript3.Syntax

12

13−import Generate.JavaScript.Helpers

13+import Generate.JavaScript.Helpers as Help

14import qualified Generate.Cases as Case

15import qualified Generate.JavaScript.Ports as Port

16+import qualified Generate.JavaScript.Variable as Var

16import qualified Generate.Markdown as MD

17import qualified Generate.Markdown as MD

18+

17−import SourceSyntax.Annotation

19+import AST.Annotation

18−import SourceSyntax.Expression

20+import AST.Module

21+import AST.Expression.General

22+import qualified AST.Expression.Canonical as Canonical

19−import qualified SourceSyntax.Helpers as Help

23+import qualified AST.Module as Module

24+import qualified AST.Helpers as Help

20−import SourceSyntax.Literal

25+import AST.Literal

21−import SourceSyntax.Module

22−import qualified SourceSyntax.Pattern as P

26+import qualified AST.Pattern as P

23−import SourceSyntax.PrettyPrint (renderPretty)

24−import qualified SourceSyntax.Variable as V

27+import qualified AST.Variable as Var

25−import qualified Transform.SafeNames as MakeSafe

26

28

27varDecl :: String -> Expression () -> VarDecl ()

29varDecl :: String -> Expression () -> VarDecl ()

28varDecl x expr =

30varDecl x expr =

29 VarDecl () (var x) (Just expr)

31 VarDecl () (var x) (Just expr)

30

32

31−include :: String -> String -> VarDecl ()

33+internalImports :: String -> [VarDecl ()]

32−include alias moduleName =

33− varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

34−

35−internalImports :: String -> Statement ()

36internalImports name =

34internalImports name =

37− VarDeclStmt ()

38− [ varDecl "_N" (obj "Elm.Native")

35+ [ varDecl "_N" (obj ["Elm","Native"])

39− , include "_U" "_N.Utils"

36+ , include "_U" "Utils"

40− , include "_L" "_N.List"

37+ , include "_L" "List"

41− , include "_A" "_N.Array"

38+ , include "_A" "Array"

42− , include "_E" "_N.Error"

39+ , include "_E" "Error"

43− , varDecl "$moduleName" (string name)

40+ , varDecl Help.localModuleName (string name)

44 ]

41 ]

42+ where

43+ include :: String -> String -> VarDecl ()

44+ include alias modul =

45+ varDecl alias (obj ["_N", modul, "make"] <| ref "_elm")

46+

47+_Utils :: String -> Expression ()

48+_Utils x = obj ["_U", x]

49+

50+_List :: String -> Expression ()

51+_List x = obj ["_L", x]

45

52

46literal :: Literal -> Expression ()

53literal :: Literal -> Expression ()

47literal lit =

54literal lit =

48 case lit of

55 case lit of

49− Chr c -> obj "_U.chr" <| string [c]

56+ Chr c -> _Utils "chr" <| string [c]

50 Str s -> string s

57 Str s -> string s

51 IntNum n -> IntLit () n

58 IntNum n -> IntLit () n

52 FloatNum n -> NumLit () n

59 FloatNum n -> NumLit () n

53 Boolean b -> BoolLit () b

60 Boolean b -> BoolLit () b

54

61

55−expression :: Expr -> State Int (Expression ())

62+expression :: Canonical.Expr -> State Int (Expression ())

56expression (A region expr) =

63expression (A region expr) =

57 case expr of

64 case expr of

58− Var (V.Raw x) -> return $ obj x

65+ Var var -> return $ Var.canonical var

59

66

60 Literal lit -> return $ literal lit

67 Literal lit -> return $ literal lit

61

68

62 Range lo hi ->

69 Range lo hi ->

63 do lo' <- expression lo

70 do lo' <- expression lo

64 hi' <- expression hi

71 hi' <- expression hi

65− return $ obj "_L.range" `call` [lo',hi']

72+ return $ _List "range" `call` [lo',hi']

66

73

67 Access e x ->

74 Access e x ->

68 do e' <- expression e

75 do e' <- expression e

@@ -70,19 +77,19 @@ expression (A region expr) =

70

77

71 Remove e x ->

78 Remove e x ->

72 do e' <- expression e

79 do e' <- expression e

73− return $ obj "_U.remove" `call` [string x, e']

80+ return $ _Utils "remove" `call` [string x, e']

74

81

75 Insert e x v ->

82 Insert e x v ->

76 do v' <- expression v

83 do v' <- expression v

77 e' <- expression e

84 e' <- expression e

78− return $ obj "_U.insert" `call` [string x, v', e']

85+ return $ _Utils "insert" `call` [string x, v', e']

79

86

80 Modify e fs ->

87 Modify e fs ->

81 do e' <- expression e

88 do e' <- expression e

82 fs' <- forM fs $ \(f,v) -> do

89 fs' <- forM fs $ \(f,v) -> do

83 v' <- expression v

90 v' <- expression v

84 return $ ArrayLit () [string f, v']

91 return $ ArrayLit () [string f, v']

85− return $ obj "_U.replace" `call` [ArrayLit () fs', e']

92+ return $ _Utils "replace" `call` [ArrayLit () fs', e']

86

93

87 Record fields ->

94 Record fields ->

88 do fields' <- forM fields $ \(f,e) -> do

95 do fields' <- forM fields $ \(f,e) -> do

@@ -106,10 +113,10 @@ expression (A region expr) =

106 where

113 where

107 depattern (args, body) pattern =

114 depattern (args, body) pattern =

108 case pattern of

115 case pattern of

109− P.Var x -> return (args ++ [x], body)

116+ P.Var x -> return (args ++ [ Var.varName x ], body)

110 _ -> do arg <- Case.newVar

117 _ -> do arg <- Case.newVar

111 return ( args ++ [arg]

118 return ( args ++ [arg]

112− , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))

119+ , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

113

120

114 (patterns, innerBody) = collect [p] e

121 (patterns, innerBody) = collect [p] e

115

122

@@ -142,9 +149,10 @@ expression (A region expr) =

142 MultiIf branches ->

149 MultiIf branches ->

143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

150 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

144 return $ case last branches of

151 return $ case last branches of

152+ (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

145− (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'

153+ safeIfs branches'

146 (A _ (Literal (Boolean True)), _) -> safeIfs branches'

154 (A _ (Literal (Boolean True)), _) -> safeIfs branches'

147− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

155+ _ -> ifs branches' (throw "If" region)

148 where

156 where

149 safeIfs branches = ifs (init branches) (snd (last branches))

157 safeIfs branches = ifs (init branches) (snd (last branches))

150 ifs branches finally = foldr iff finally branches

158 ifs branches finally = foldr iff finally branches

@@ -154,7 +162,7 @@ expression (A region expr) =

154 do (tempVar,initialMatch) <- Case.toMatch cases

162 do (tempVar,initialMatch) <- Case.toMatch cases

155 (revisedMatch, stmt) <-

163 (revisedMatch, stmt) <-

156 case e of

164 case e of

157− A _ (Var (V.Raw x)) ->

165+ A _ (Var (Var.Canonical Var.Local x)) ->

158 return (Case.matchSubst [(tempVar,x)] initialMatch, [])

166 return (Case.matchSubst [(tempVar,x)] initialMatch, [])

159 _ ->

167 _ ->

160 do e' <- expression e

168 do e' <- expression e

@@ -164,7 +172,7 @@ expression (A region expr) =

164

172

165 ExplicitList es ->

173 ExplicitList es ->

166 do es' <- mapM expression es

174 do es' <- mapM expression es

167− return $ obj "_L.fromArray" <| ArrayLit () es'

175+ return $ _List "fromArray" <| ArrayLit () es'

168

176

169 Data name es ->

177 Data name es ->

170 do es' <- mapM expression es

178 do es' <- mapM expression es

@@ -175,7 +183,7 @@ expression (A region expr) =

175

183

176 Markdown uid doc es ->

184 Markdown uid doc es ->

177 do es' <- mapM expression es

185 do es' <- mapM expression es

178− return $ obj "Text.markdown" `call` (string md : string uid : es')

186+ return $ Var.value "Text" "markdown" `call` (string md : string uid : es')

179 where

187 where

180 pad = "<div style=\"height:0;width:0;\"> </div>"

188 pad = "<div style=\"height:0;width:0;\"> </div>"

181 md = pad ++ MD.toHtml doc ++ pad

189 md = pad ++ MD.toHtml doc ++ pad

@@ -184,15 +192,16 @@ expression (A region expr) =

184 return $ ObjectLit () [(PropString () "src", literal (Str src))]

192 return $ ObjectLit () [(PropString () "src", literal (Str src))]

185

193

186 PortIn name tipe ->

194 PortIn name tipe ->

195+ return $ Var.value "Native.Ports" "portIn" `call`

187− return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]

196+ [ string name, Port.incoming tipe ]

188

197

189 PortOut name tipe value ->

198 PortOut name tipe value ->

190 do value' <- expression value

199 do value' <- expression value

191− return $ obj "Native.Ports.portOut" `call`

200+ return $ Var.value "Native.Ports" "portOut" `call`

192 [ string name, Port.outgoing tipe, value' ]

201 [ string name, Port.outgoing tipe, value' ]

193

202

194−definition :: Def -> State Int [Statement ()]

203+definition :: Canonical.Def -> State Int [Statement ()]

195−definition (Definition pattern expr@(A region _) _) = do

204+definition (Canonical.Definition pattern expr@(A region _) _) = do

196 expr' <- expression expr

205 expr' <- expression expr

197 let assign x = varDecl x expr'

206 let assign x = varDecl x expr'

198 case pattern of

207 case pattern of

@@ -201,39 +210,39 @@ definition (Definition pattern expr@(A region _) _) = do

201 let op = LBracket () (ref "_op") (string x) in

210 let op = LBracket () (ref "_op") (string x) in

202 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

211 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

203 | otherwise ->

212 | otherwise ->

204− return [ VarDeclStmt () [ assign x ] ]

213+ return [ VarDeclStmt () [ assign (Var.varName x) ] ]

205

214

206 P.Record fields ->

215 P.Record fields ->

207− let setField f = varDecl f (dotSep ["$",f]) in

216+ let setField f = varDecl f (obj ["$",f]) in

208 return [ VarDeclStmt () (assign "$" : map setField fields) ]

217 return [ VarDeclStmt () (assign "$" : map setField fields) ]

209

218

210− P.Data name patterns | vars /= Nothing ->

219+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

211 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

220 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

212 where

221 where

213 vars = getVars patterns

222 vars = getVars patterns

214 getVars patterns =

223 getVars patterns =

215 case patterns of

224 case patterns of

216− P.Var x : rest -> (x:) `fmap` getVars rest

225+ P.Var x : rest -> (Var.varName x :) `fmap` getVars rest

217 [] -> Just []

226 [] -> Just []

218 _ -> Nothing

227 _ -> Nothing

219

228

220− decl x n = varDecl x (dotSep ["$","_" ++ show n])

229+ decl x n = varDecl x (obj ["$","_" ++ show n])

221 setup vars

230 setup vars

222 | Help.isTuple name = assign "$" : vars

231 | Help.isTuple name = assign "$" : vars

223 | otherwise = assign "_raw" : safeAssign : vars

232 | otherwise = assign "_raw" : safeAssign : vars

224

233

225− safeAssign = varDecl "$" (CondExpr () if' (obj "_raw") exception)

234+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)

226− if' = InfixExpr () OpStrictEq (obj "_raw.ctor") (string name)

235+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)

227− exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]

236+ exception = Help.throw "Case" region

228

237

229 _ ->

238 _ ->

230 do defs' <- concat <$> mapM toDef vars

239 do defs' <- concat <$> mapM toDef vars

231 return (VarDeclStmt () [assign "_"] : defs')

240 return (VarDeclStmt () [assign "_"] : defs')

232 where

241 where

233 vars = P.boundVarList pattern

242 vars = P.boundVarList pattern

234− mkVar = A region . rawVar

243+ mkVar = A region . localVar

235 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

244 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

236− in definition $ Definition (P.Var y) expr Nothing

245+ in definition $ Canonical.Definition (P.Var y) expr Nothing

237

246

238match :: Region -> Case.Match -> State Int [Statement ()]

247match :: Region -> Case.Match -> State Int [Statement ()]

239match region mtch =

248match region mtch =

@@ -248,15 +257,15 @@ match region mtch =

248 _ -> False

257 _ -> False

249

258

250 access name

259 access name

251− | any isLiteral clauses = obj name

260+ | any isLiteral clauses = obj [name]

252− | otherwise = dotSep (split name ++ ["ctor"])

261+ | otherwise = obj (Help.splitDots name ++ ["ctor"])

253

262

254 format isChars e

263 format isChars e

255 | or isChars = InfixExpr () OpAdd e (string "")

264 | or isChars = InfixExpr () OpAdd e (string "")

256 | otherwise = e

265 | otherwise = e

257

266

258 Case.Fail ->

267 Case.Fail ->

259− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]

268+ return [ ExprStmt () (Help.throw "Case" region) ]

260

269

261 Case.Break -> return [BreakStmt () Nothing]

270 Case.Break -> return [BreakStmt () Nothing]

262

271

@@ -283,98 +292,123 @@ clause region variable (Case.Clause value vars mtch) =

283 _ -> (,) False $ case value of

292 _ -> (,) False $ case value of

284 Right (Boolean b) -> BoolLit () b

293 Right (Boolean b) -> BoolLit () b

285 Right lit -> literal lit

294 Right lit -> literal lit

286− Left name -> string $ case List.elemIndices '.' name of

295+ Left (Var.Canonical _ name) ->

287− [] -> name

296+ string name

288− is -> drop (last is + 1) name

289

297

290−flattenLets :: [Def] -> Expr -> ([Def], Expr)

298+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

291flattenLets defs lexpr@(A _ expr) =

299flattenLets defs lexpr@(A _ expr) =

292 case expr of

300 case expr of

293 Let ds body -> flattenLets (defs ++ ds) body

301 Let ds body -> flattenLets (defs ++ ds) body

294 _ -> (defs, lexpr)

302 _ -> (defs, lexpr)

295

303

296−generate :: MetadataModule -> String

304+generate :: CanonicalModule -> String

297−generate unsafeModule =

305+generate modul =

298− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

306+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

299− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

307+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

300 where

308 where

301− modul = MakeSafe.metadataModule unsafeModule

309+ names :: [String]

310+ names = Module.names modul

311+

312+ thisModule :: Expression ()

302− thisModule = dotSep ("_elm" : names modul ++ ["values"])

313+ thisModule = obj ("_elm" : names ++ ["values"])

314+

315+ programStmts :: [Statement ()]

303 programStmts =

316 programStmts =

304 concat

317 concat

305− [ [ ExprStmt () $ string "use strict" ]

318+ [ [ ExprStmt () (string "use strict") ]

306− , setup (Just "_elm") (names modul ++ ["values"])

319+ , setup "_elm" (names ++ ["values"])

307 , [ IfSingleStmt () thisModule (ret thisModule) ]

320 , [ IfSingleStmt () thisModule (ret thisModule) ]

308− , [ internalImports (List.intercalate "." (names modul)) ]

321+ , [ VarDeclStmt () localVars ]

309− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

322+ , body

310− , [ assign ["_op"] (ObjectLit () []) ]

311− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

312 , [ jsExports ]

323 , [ jsExports ]

313 , [ ret thisModule ]

324 , [ ret thisModule ]

314 ]

325 ]

315

326

327+ localVars :: [VarDecl ()]

328+ localVars = varDecl "_op" (ObjectLit () []) :

329+ internalImports (Module.getName modul) ++

330+ explicitImports

331+ where

332+ explicitImports :: [VarDecl ()]

333+ explicitImports =

334+ map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

335+

336+ jsImport :: String -> VarDecl ()

337+ jsImport name =

338+ varDecl (Var.moduleName name) $

339+ obj ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

340+

341+ body :: [Statement ()]

342+ body = concat $ evalState defs 0

343+ where

344+ defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)

345+

346+ setup namespace path = map create paths

347+ where

348+ create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))

349+ paths = drop 2 . init . List.inits $ namespace : path

350+

316− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

351+ jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

317 where

352 where

318− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul

353+ exs = map entry $ "_op" : concatMap extract (exports modul)

319 entry x = (prop x, ref x)

354 entry x = (prop x, ref x)

355+ extract value =

356+ case value of

357+ Var.Alias _ -> []

358+ Var.Value x | Help.isOp x -> []

359+ | otherwise -> [Var.varName x]

360+ Var.ADT _ (Var.Listing ctors _) -> map Var.varName ctors

320

361

321 assign path expr =

362 assign path expr =

322 case path of

363 case path of

323 [x] -> VarDeclStmt () [ varDecl x expr ]

364 [x] -> VarDeclStmt () [ varDecl x expr ]

324 _ -> ExprStmt () $

365 _ -> ExprStmt () $

325− AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

366+ AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

326−

327− jsImport modul = setup Nothing path ++ [ include ]

328− where

329− path = Help.splitDots modul

330− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

331

367

332− setup namespace path = map create paths

368+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

333− where

334− create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

335− paths = case namespace of

336− Nothing -> tail . init $ List.inits path

337− Just nmspc -> drop 2 . init . List.inits $ nmspc : path

338−

339−binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())

369+ -> State Int (Expression ())

340−binop region op e1 e2 =

370+binop region func@(Var.Canonical home op) e1 e2 =

341− case op of

371+ case (home, op) of

342− "Basics.." ->

372+ (Var.Module "Basics", ".") ->

343 do es <- mapM expression (e1 : collect [] e2)

373 do es <- mapM expression (e1 : collect [] e2)

344 return $ ["$"] ==> foldr (<|) (ref "$") es

374 return $ ["$"] ==> foldr (<|) (ref "$") es

345− "Basics.<|" ->

375+

376+ (Var.Module "Basics", "<|") ->

346 do e2' <- expression e2

377 do e2' <- expression e2

347 es <- mapM expression (collect [] e1)

378 es <- mapM expression (collect [] e1)

348 return $ foldr (<|) e2' es

379 return $ foldr (<|) e2' es

349− "List.++" ->

380+

381+ (Var.Module "List", "++") ->

350 do e1' <- expression e1

382 do e1' <- expression e1

351 e2' <- expression e2

383 e2' <- expression e2

352− return $ obj "_L.append" `call` [e1', e2']

384+ return $ _List "append" `call` [e1', e2']

385+

386+ (Var.BuiltIn, "::") ->

353− "::" -> expression (A region (Data "::" [e1,e2]))

387+ expression (A region (Data "::" [e1,e2]))

354− _ ->

388+

389+ (Var.Module "Basics", _) ->

355 do e1' <- expression e1

390 do e1' <- expression e1

356 e2' <- expression e2

391 e2' <- expression e2

357− return $ case Map.lookup op opDict of

392+ return $ case Map.lookup op basicOps of

358 Just f -> f e1' e2'

393 Just f -> f e1' e2'

359− Nothing -> ref "A2" `call` [ func, e1', e2' ]

394+ Nothing -> ref "A2" `call` [ Var.canonical func, e1', e2' ]

395+

396+ _ ->

397+ do e1' <- expression e1

398+ e2' <- expression e2

399+ return (ref "A2" `call` [ Var.canonical func, e1', e2' ])

400+

360 where

401 where

361 collect es e =

402 collect es e =

362 case e of

403 case e of

404+ A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->

363− A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

405+ collect (es ++ [e1]) e2

364 _ -> es ++ [e]

406 _ -> es ++ [e]

365

407

366− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

367− | otherwise = dotSep parts

368− where

369− parts = Help.splitDots op

370− operator = last parts

371−

372− opDict = Map.fromList (infixOps ++ specialOps)

408+ basicOps = Map.fromList (infixOps ++ specialOps)

373−

374− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]

375− infixOp str op = specialOp str (InfixExpr () op)

376

409

377− infixOps = concat

410+ infixOps =

411+ let infixOp str op = (str, InfixExpr () op) in

378 [ infixOp "+" OpAdd

412 [ infixOp "+" OpAdd

379 , infixOp "-" OpSub

413 , infixOp "-" OpSub

380 , infixOp "*" OpMul

414 , infixOp "*" OpMul

@@ -383,16 +417,16 @@ binop region op e1 e2 =

383 , infixOp "||" OpLOr

417 , infixOp "||" OpLOr

384 ]

418 ]

385

419

386− specialOps = concat

420+ specialOps =

387− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

421+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

388− , specialOp "|>" $ flip (<|)

422+ , (,) "|>" $ flip (<|)

389− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

423+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

390− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

424+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

391− , specialOp "<" $ cmp OpLT 0

425+ , (,) "<" $ cmp OpLT 0

392− , specialOp ">" $ cmp OpGT 0

426+ , (,) ">" $ cmp OpGT 0

393− , specialOp "<=" $ cmp OpLT 1

427+ , (,) "<=" $ cmp OpLT 1

394− , specialOp ">=" $ cmp OpGT (-1)

428+ , (,) ">=" $ cmp OpGT (-1)

395− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

429+ , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

396 ]

430 ]

397

431

398− cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

432+ cmp op n a b = InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hs+45−16

@@ -1,37 +1,66 @@

1{-# OPTIONS_GHC -W #-}

2module Generate.JavaScript.Helpers where

3

4−import qualified SourceSyntax.Helpers as Help

4+import AST.Annotation (Region)

5+import qualified AST.PrettyPrint as PP

5import Language.ECMAScript3.Syntax

6import Language.ECMAScript3.Syntax

6

7

7−split :: String -> [String]

8+-- Creating Variables

8−split = go []

9− where

10− go vars str =

11− case break (=='.') str of

12− (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

13− | otherwise -> go (vars ++ [x]) rest

14− (x,[]) -> vars ++ [x]

15

9

10+var :: String -> Id ()

16var name = Id () name

11var name = Id () name

12+

13+ref :: String -> Expression ()

17ref name = VarRef () (var name)

14ref name = VarRef () (var name)

15+

16+prop :: String -> Prop ()

18prop name = PropId () (var name)

17prop name = PropId () (var name)

19−f <| x = CallExpr () f [x]

18+

20−ret e = ReturnStmt () (Just e)

21−args ==> e = FuncExpr () Nothing (map var args) [ ret e ]

22−function args stmts = FuncExpr () Nothing (map var args) stmts

23−call = CallExpr ()

24string = StringLit ()

19string = StringLit ()

25

20

21+obj :: [String] -> Expression ()

26−dotSep vars =

22+obj vars =

27 case vars of

23 case vars of

28 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

24 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

29 [] -> error "dotSep must be called on a non-empty list of variables"

25 [] -> error "dotSep must be called on a non-empty list of variables"

30

26

31−obj = dotSep . split

27+-- Specific Utilities

32

28

29+localModuleName :: String

30+localModuleName = "$moduleName"

31+

32+throw :: String -> Region -> Expression ()

33+throw kind region =

34+ obj ["_E",kind] `call` [ ref localModuleName, string (PP.renderPretty region) ]

35+

36+-- Function Calls

37+

38+(<|) :: Expression () -> Expression () -> Expression ()

39+(<|) f x = CallExpr () f [x]

40+

41+ret :: Expression () -> Statement ()

42+ret e = ReturnStmt () (Just e)

43+

44+(==>) :: [String] -> Expression () -> Expression ()

45+(==>) args e = FuncExpr () Nothing (map var args) [ ret e ]

46+

47+function :: [String] -> [Statement ()] -> Expression ()

48+function args stmts = FuncExpr () Nothing (map var args) stmts

49+

50+call :: Expression () -> [Expression ()] -> Expression ()

51+call = CallExpr ()

52+

53+-- Checks

54+

55+equal :: Expression () -> Expression () -> Expression ()

33equal a b = InfixExpr () OpStrictEq a b

56equal a b = InfixExpr () OpStrictEq a b

57+

58+instanceof :: String -> Expression () -> Expression ()

34instanceof tipe x =

59instanceof tipe x =

35 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

60 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61+

62+typeof :: String -> Expression () -> Expression ()

36typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

63typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64+

65+member :: String -> Expression () -> Expression ()

37member field x = InfixExpr () OpIn (string field) x

66member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hs+82−64

@@ -2,8 +2,9 @@

2module Generate.JavaScript.Ports (incoming, outgoing) where

3

4import Generate.JavaScript.Helpers

5−import qualified SourceSyntax.Helpers as Help

5+import qualified Generate.JavaScript.Variable as V

6−import SourceSyntax.Type as T

6+import AST.Type as T

7+import qualified AST.Variable as Var

7import Language.ECMAScript3.Syntax

8import Language.ECMAScript3.Syntax

8

9

9data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

10data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

@@ -14,64 +15,71 @@ check x jsType continue =

14 CondExpr () (jsFold OpLOr checks x) continue throw

15 CondExpr () (jsFold OpLOr checks x) continue throw

15 where

16 where

16 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17 jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17− throw = obj "_E.raise" <| InfixExpr () OpAdd msg x

18+ throw = obj ["_E","raise"] <| InfixExpr () OpAdd msg x

18 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19 checks = case jsType of

20 checks = case jsType of

20 JSNumber -> [typeof "number"]

21 JSNumber -> [typeof "number"]

21 JSBoolean -> [typeof "boolean"]

22 JSBoolean -> [typeof "boolean"]

22 JSString -> [typeof "string", instanceof "String"]

23 JSString -> [typeof "string", instanceof "String"]

23− JSArray -> [(obj "_U.isJSArray" <|)]

24+ JSArray -> [(obj ["_U","isJSArray"] <|)]

24 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25

26

26−incoming :: Type -> Expression ()

27+incoming :: CanonicalType -> Expression ()

27incoming tipe =

28incoming tipe =

28 case tipe of

29 case tipe of

29− Data "Signal.Signal" [t] ->

30+ Aliased _ t -> incoming t

31+

32+ App (Type v) [t]

30− obj "Native.Ports.incomingSignal" <| incoming t

33+ | Var.isSignal v -> V.value "Native.Ports" "incomingSignal" <| incoming t

34+

31 _ -> ["v"] ==> inc tipe (ref "v")

35 _ -> ["v"] ==> inc tipe (ref "v")

32

36

33−inc :: Type -> Expression () -> Expression ()

37+inc :: CanonicalType -> Expression () -> Expression ()

34inc tipe x =

38inc tipe x =

35 case tipe of

39 case tipe of

36 Lambda _ _ -> error "functions should not be allowed through input ports"

40 Lambda _ _ -> error "functions should not be allowed through input ports"

37 Var _ -> error "type variables should not be allowed through input ports"

41 Var _ -> error "type variables should not be allowed through input ports"

38−

42+ Aliased _ t ->

39− Data "Json.Value" [] ->

43+ inc t x

40− obj "Native.Json.fromJS" <| x

44+

41−

45+ Type (Var.Canonical Var.BuiltIn name)

42− Data ctor []

43− | ctor == "Int" -> from JSNumber

46+ | name == "Int" -> from JSNumber

44− | ctor == "Float" -> from JSNumber

47+ | name == "Float" -> from JSNumber

45− | ctor == "Bool" -> from JSBoolean

48+ | name == "Bool" -> from JSBoolean

46− | ctor == "String" -> from JSString

49+ | name == "String" -> from JSString

47 where

50 where

48 from checks = check x checks x

51 from checks = check x checks x

49

52

50− Data ctor [t]

53+ Type name

51− | ctor == "Maybe.Maybe" ->

54+ | Var.isJson name -> V.value "Native.Json" "fromJS" <| x

52− CondExpr () (equal x (NullLit ()))

55+ | otherwise -> error "bad type got to incoming port generation code"

53− (obj "Maybe.Nothing")

54− (obj "Maybe.Just" <| inc t x)

55

56

56− | ctor == "_List" ->

57+ App f args ->

57− check x JSArray (obj "_L.fromArray" <| array)

58+ case f : args of

59+ Type name : [t]

60+ | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))

61+ (V.value "Maybe" "Nothing")

62+ (V.value "Maybe" "Just" <| inc t x)

58

63

59− | ctor == "Array.Array" ->

60− check x JSArray (obj "_A.fromJSArray" <| array)

64+ | Var.isList name -> check x JSArray (obj ["_L","fromArray"] <| array)

61

65

66+ | Var.isArray name -> check x JSArray (obj ["_A","fromJSArray"] <| array)

62− where

67+ where

63− array = DotRef () x (var "map") <| incoming t

68+ array = DotRef () x (var "map") <| incoming t

64

69

65− Data ctor ts

70+ Type name : ts

66− | Help.isTuple ctor -> check x JSArray tuple

71+ | Var.isTuple name -> check x JSArray tuple

67− where

72+ where

68− tuple = ObjectLit () $ (prop "ctor", string ctor) : values

73+ tuple = ObjectLit () $ (prop "ctor", ctor) : values

74+

75+ ctor = string ("_Tuple" ++ show (length ts))

69− values = zipWith convert [0..] ts

76+ values = zipWith convert [0..] ts

70− convert n t = ( prop ('_':show n)

71− , inc t (BracketRef () x (IntLit () n)))

72

77

73− Data _ _ ->

78+ convert n t = ( prop ('_':show n)

79+ , inc t (BracketRef () x (IntLit () n))

80+ )

81+

74− error "bad ADT got to incoming port generation code"

82+ _ -> error "bad ADT got to incoming port generation code"

75

83

76 Record _ (Just _) ->

84 Record _ (Just _) ->

77 error "bad record got to incoming port generation code"

85 error "bad record got to incoming port generation code"

@@ -83,15 +91,21 @@ inc tipe x =

83 keys = map convert fields

91 keys = map convert fields

84 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

92 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

85

93

94+outgoing :: CanonicalType -> Expression ()

86outgoing tipe =

95outgoing tipe =

87 case tipe of

96 case tipe of

88− Data "Signal.Signal" [t] ->

97+ Aliased _ t -> outgoing t

98+

99+ App (Type v) [t]

89− obj "Native.Ports.outgoingSignal" <| outgoing t

100+ | Var.isSignal v -> V.value "Native.Ports" "outgoingSignal" <| outgoing t

101+

90 _ -> ["v"] ==> out tipe (ref "v")

102 _ -> ["v"] ==> out tipe (ref "v")

91

103

92−out :: Type -> Expression () -> Expression ()

104+out :: CanonicalType -> Expression () -> Expression ()

93out tipe x =

105out tipe x =

94 case tipe of

106 case tipe of

107+ Aliased _ t -> out t x

108+

95 Lambda _ _

109 Lambda _ _

96 | numArgs > 1 && numArgs < 10 ->

110 | numArgs > 1 && numArgs < 10 ->

97 func (ref ('A':show numArgs) `call` (x:values))

111 func (ref ('A':show numArgs) `call` (x:values))

@@ -107,30 +121,34 @@ out tipe x =

107 ]

121 ]

108

122

109 Var _ -> error "type variables should not be allowed through input ports"

123 Var _ -> error "type variables should not be allowed through input ports"

110− Data ctor []

124+

125+ Type (Var.Canonical Var.BuiltIn name)

111− | ctor `elem` ["Int","Float","Bool","String"] -> x

126+ | name `elem` ["Int","Float","Bool","String"] -> x

112− | ctor == "Json.Value" ->

127+

128+ Type name

113− obj "Native.Json.toJS" <| x

129+ | Var.isJson name -> V.value "Native.Json" "toJS" <| x

114−

130+ | otherwise -> error "bad type got to outgoing port generation code"

115− Data ctor [t]

131+

116− | ctor == "Maybe.Maybe" ->

132+ App f args ->

133+ case f : args of

134+ Type name : [t]

135+ | Var.isMaybe name ->

117− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

136+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

118− (NullLit ())

137+ (NullLit ())

119− (out t (DotRef () x (var "_0")))

138+ (out t (DotRef () x (var "_0")))

120−

139+

121− | ctor == "_List" ->

140+ | Var.isArray name ->

141+ DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

142+

143+ | Var.isList name ->

122− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

144+ DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

123−

145+

124− | ctor == "Array.Array" ->

146+ Type name : ts

125− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

126−

127− Data ctor ts

128− | Help.isTuple ctor ->

147+ | Var.isTuple name ->

129− let convert n t = out t $ DotRef () x $ var ('_':show n)

148+ let convert n t = out t $ DotRef () x $ var ('_':show n)

130− in ArrayLit () $ zipWith convert [0..] ts

149+ in ArrayLit () $ zipWith convert [0..] ts

131−

150+

132− Data _ _ ->

133− error "bad ADT got to outgoing port generation code"

151+ _ -> error "bad ADT got to outgoing port generation code"

134

152

135 Record _ (Just _) ->

153 Record _ (Just _) ->

136 error "bad record got to outgoing port generation code"

154 error "bad record got to outgoing port generation code"

compiler/Generate/JavaScript/Variable.hsnew file+53

@@ -0,0 +1,53 @@

1+{-# OPTIONS_GHC -W #-}

2+module Generate.JavaScript.Variable where

3+

4+import qualified AST.Helpers as Help

5+import qualified AST.Variable as Var

6+import qualified Data.Set as Set

7+import qualified Generate.JavaScript.Helpers as JS

8+import qualified Language.ECMAScript3.Syntax as JS

9+

10+swap :: Char -> Char -> Char -> Char

11+swap from to c = if c == from then to else c

12+

13+canonical :: Var.Canonical -> JS.Expression ()

14+canonical (Var.Canonical home name) =

15+ case Help.isOp name of

16+ True -> JS.BracketRef () (JS.obj (home' ++ ["_op"])) (JS.string name)

17+ False -> JS.obj (home' ++ [ varName name ])

18+ where

19+ home' =

20+ case home of

21+ Var.Local -> []

22+ Var.BuiltIn -> []

23+ Var.Module path -> [ moduleName path ]

24+

25+moduleName :: String -> String

26+moduleName x = '$' : map (swap '.' '$') x

27+

28+varName :: String -> String

29+varName x = map (swap '\'' '$') x'

30+ where

31+ x' = if Set.member x jsReserveds then '$' : x else x

32+

33+value :: String -> String -> JS.Expression ()

34+value home name =

35+ canonical (Var.Canonical (Var.Module home) name)

36+

37+jsReserveds :: Set.Set String

38+jsReserveds = Set.fromList

39+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

40+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

41+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

42+ , "transient", "synchronized", "function", "break", "case", "catch"

43+ , "continue", "debugger", "default", "delete", "do", "else", "finally"

44+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

45+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

46+ , "const", "enum", "export", "extends", "import", "super", "implements"

47+ , "interface", "let", "package", "private", "protected", "public"

48+ , "static", "yield"

49+ -- reserved by the Elm runtime system

50+ , "Elm", "ElmRuntime"

51+ , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

52+ , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

53+ ]

compiler/Language/Elm/DevTools.hsdeleted−46

@@ -1,46 +0,0 @@

1−{- | This module aims to make it easier to create dev tools for Elm.

2−

3− It provides the ability to:

4−

5− * Detect problems in a program

6− * Figure out types of particular expressions

7− * Canonicalize variables

8− * Convert expressions to JS and HTML

9−

10− This module gives limeted access to the structure of an Elm Program.

11− Giving full access would expose many internal details that are likely to

12− change as Elm progresses. These details have been hidden to avoid breaking

13− changes.

14−-}

15−module Language.Elm.DevTools where

16−

17−data Program

18−

19−-- | Parse an Elm program into an AST.

20−parse :: String -> Either [Problem] Program

21−

22−-- | Get the type of a region of the program. Lets you look

23−-- up the type of particular values and expressions.

24−typeOf :: Program -> Region -> Either [Problem] String

25−

26−-- | Canonicalize a variable. So in a normal module `map` would be canonicalized

27−-- to `List.map`.

28−canonicalize :: Program -> Region -> [String]

29−

30−-- | Any problem that may come up while parsing or typing a program.

31−-- All problems come with a region that is causing the problem.

32−data Problem = Problem { message :: String, region :: Region }

33−

34−type Row = Int

35−type Column = Int

36−

37−-- | Represents a region, spanning two points in the source code.

38−data Region = Region { start :: (Row,Column), end :: (Row,Column) }

39−

40−-- | Takes a specific point in the source code, such as the cursor position.

41−-- It then determines the region that best represents that point. When the

42−-- cursor is within a variable, it chooses the variable. When the cursor is

43−-- on parentheses, it selects the region within the parentheses. When the

44−-- cursor is on keywords like let, it chooses the whole let-expression.

45−region :: (Row,Column) -> Region

46−region pos = Region pos pos

compiler/Metadata/Prelude.hs+22−9

@@ -5,12 +5,14 @@ import qualified Data.Map as Map

5import qualified Control.Exception as E

6import System.Exit

7import System.IO

8−import SourceSyntax.Module

8+import AST.Module as Module

9+import qualified AST.Variable as Var

9import qualified Build.Interface as Interface

10import qualified Build.Interface as Interface

10import Build.Utils (getDataFile)

11import Build.Utils (getDataFile)

11

12

12−add :: Bool -> Module def -> Module def

13+add :: Bool -> Module exs body -> Module exs body

13−add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls

14+add noPrelude (Module name path exs ims decls) =

15+ Module name path exs (customIms ++ ims) decls

14 where

16 where

15 customIms = if noPrelude then [] else concatMap addModule prelude

17 customIms = if noPrelude then [] else concatMap addModule prelude

16

18

@@ -20,15 +22,26 @@ add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) d

20 Just _ -> []

22 Just _ -> []

21

23

22prelude :: [(String, ImportMethod)]

24prelude :: [(String, ImportMethod)]

23−prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules

25+prelude = string : text : maybe : map (\n -> (n, Module.open)) modules

24 where

26 where

25− text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

26− string = map ((,) "String") [ As "String", Importing ["show"] ]

27− modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Color"

27+ modules = [ "Basics", "Signal", "List", "Time", "Color"

28 , "Graphics.Element", "Graphics.Collage"

29 , "Native.Ports", "Native.Json"

30 ]

31

32+ string = ("String", Module.importing [Var.Value "show"])

33+

34+ text = ("Text", Module.importing textImports)

35+ textImports =

36+ Var.ADT "Text" (Var.Listing [] False) : map Var.Value

37+ [ "toText", "leftAligned", "rightAligned", "centered", "justified"

38+ , "plainText", "asText", "typeface", "monospace", "bold", "italic"

39+ ]

40+

41+ maybe =

42+ let imports = [ Var.ADT "Maybe" (Var.Listing ["Just", "Nothing"] False) ]

43+ in ("Maybe", Module.importing imports)

44+

32interfaces :: Bool -> IO Interfaces

45interfaces :: Bool -> IO Interfaces

33interfaces noPrelude =

46interfaces noPrelude =

34 if noPrelude

47 if noPrelude

@@ -42,14 +55,14 @@ safeReadDocs name =

42 hPutStrLn stderr $ unlines $

55 hPutStrLn stderr $ unlines $

43 [ "Error reading types for standard library from file " ++ name

56 [ "Error reading types for standard library from file " ++ name

44 , " If you are using a stable version of Elm, please report an issue at"

57 , " If you are using a stable version of Elm, please report an issue at"

45− , " <http://github.com/evancz/Elm/issues> specifying version numbers for"

58+ , " <http://github.com/elm-lang/Elm/issues> specifying version numbers for"

46 , " Elm and your OS." ]

59 , " Elm and your OS." ]

47 exitFailure

60 exitFailure

48

61

49readDocs :: FilePath -> IO Interfaces

62readDocs :: FilePath -> IO Interfaces

50readDocs filePath = do

63readDocs filePath = do

51 interfaces <- Interface.load filePath

64 interfaces <- Interface.load filePath

52− case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of

65+ case mapM (Interface.isValid filePath) (interfaces :: [(String, Module.Interface)]) of

53 Left err -> do

66 Left err -> do

54 hPutStrLn stderr err

67 hPutStrLn stderr err

55 exitFailure

68 exitFailure

compiler/Parse/Binop.hs+19−17

@@ -5,9 +5,11 @@ import Control.Applicative ((<$>))

5import qualified Data.List as List

6import qualified Data.Map as Map

7

8−import SourceSyntax.Annotation (merge)

8+import AST.Annotation (merge)

9−import qualified SourceSyntax.Expression as E

10−import SourceSyntax.Declaration (Assoc(..))

9+import AST.Declaration (Assoc(..))

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

11+import qualified AST.Expression.Source as Source

12+import qualified AST.Variable as Var

11import Text.Parsec

13import Text.Parsec

12import Parse.Helpers

14import Parse.Helpers

13

15

@@ -17,13 +19,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

17opAssoc :: OpTable -> String -> Assoc

19opAssoc :: OpTable -> String -> Assoc

18opAssoc table op = snd $ Map.findWithDefault (9,L) op table

20opAssoc table op = snd $ Map.findWithDefault (9,L) op table

19

21

20−hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool

22+hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

21hasLevel table n (op,_) = opLevel table op == n

23hasLevel table n (op,_) = opLevel table op == n

22

24

23−binops :: IParser E.ParseExpr

25+binops :: IParser Source.Expr

24− -> IParser E.ParseExpr

26+ -> IParser Source.Expr

25 -> IParser String

27 -> IParser String

26− -> IParser E.ParseExpr

28+ -> IParser Source.Expr

27binops term last anyOp =

29binops term last anyOp =

28 do e <- term

30 do e <- term

29 table <- getState

31 table <- getState

@@ -39,9 +41,9 @@ binops term last anyOp =

39

41

40split :: OpTable

42split :: OpTable

41 -> Int

43 -> Int

42− -> E.ParseExpr

44+ -> Source.Expr

43− -> [(String, E.ParseExpr)]

45+ -> [(String, Source.Expr)]

44− -> IParser E.ParseExpr

46+ -> IParser Source.Expr

45split _ _ e [] = return e

47split _ _ e [] = return e

46split table n e eops = do

48split table n e eops = do

47 assoc <- getAssoc table n eops

49 assoc <- getAssoc table n eops

@@ -50,26 +52,26 @@ split table n e eops = do

50 case assoc of R -> joinR es ops

52 case assoc of R -> joinR es ops

51 _ -> joinL es ops

53 _ -> joinL es ops

52

54

53−splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]

55+splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

54− -> [IParser E.ParseExpr]

56+ -> [IParser Source.Expr]

55splitLevel table n e eops =

57splitLevel table n e eops =

56 case break (hasLevel table n) eops of

58 case break (hasLevel table n) eops of

57 (lops, (_op,e'):rops) ->

59 (lops, (_op,e'):rops) ->

58 split table (n+1) e lops : splitLevel table n e' rops

60 split table (n+1) e lops : splitLevel table n e' rops

59 (lops, []) -> [ split table (n+1) e lops ]

61 (lops, []) -> [ split table (n+1) e lops ]

60

62

61−joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

63+joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

62joinL [e] [] = return e

64joinL [e] [] = return e

63−joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops

65+joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops

64joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

66joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

65

67

66−joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

68+joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

67joinR [e] [] = return e

69joinR [e] [] = return e

68joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

70joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

69− return (merge a e (E.Binop op a e))

71+ return (merge a e (Binop (Var.Raw op) a e))

70joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

72joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

71

73

72−getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc

74+getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

73getAssoc table n eops

75getAssoc table n eops

74 | all (==L) assocs = return L

76 | all (==L) assocs = return L

75 | all (==R) assocs = return R

77 | all (==R) assocs = return R

compiler/Parse/Declaration.hs+7−8

@@ -7,16 +7,15 @@ import Text.Parsec hiding (newline,spaces)

7import Parse.Helpers

8import qualified Parse.Expression as Expr

9import qualified Parse.Type as Type

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11

12−

13−declaration :: IParser D.ParseDeclaration

12+declaration :: IParser D.SourceDecl

14declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

13declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

15

14

16−definition :: IParser D.ParseDeclaration

15+definition :: IParser D.SourceDecl

17definition = D.Definition <$> Expr.def

16definition = D.Definition <$> Expr.def

18

17

19−alias :: IParser D.ParseDeclaration

18+alias :: IParser D.SourceDecl

20alias = do

19alias = do

21 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

20 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

22 forcedWS

21 forcedWS

@@ -26,7 +25,7 @@ alias = do

26 tipe <- Type.expr

25 tipe <- Type.expr

27 return (D.TypeAlias name args tipe)

26 return (D.TypeAlias name args tipe)

28

27

29−datatype :: IParser D.ParseDeclaration

28+datatype :: IParser D.SourceDecl

30datatype = do

29datatype = do

31 reserved "data" <?> "datatype definition (data T = A | B | ...)"

30 reserved "data" <?> "datatype definition (data T = A | B | ...)"

32 forcedWS

31 forcedWS

@@ -37,7 +36,7 @@ datatype = do

37 return $ D.Datatype name args tcs

36 return $ D.Datatype name args tcs

38

37

39

38

40−infixDecl :: IParser D.ParseDeclaration

39+infixDecl :: IParser D.SourceDecl

41infixDecl = do

40infixDecl = do

42 assoc <- choice [ reserved "infixl" >> return D.L

41 assoc <- choice [ reserved "infixl" >> return D.L

43 , reserved "infix" >> return D.N

42 , reserved "infix" >> return D.N

@@ -48,7 +47,7 @@ infixDecl = do

48 D.Fixity assoc (read [n]) <$> anyOp

47 D.Fixity assoc (read [n]) <$> anyOp

49

48

50

49

51−port :: IParser D.ParseDeclaration

50+port :: IParser D.SourceDecl

52port =

51port =

53 do try (reserved "port")

52 do try (reserved "port")

54 whitespace

53 whitespace

compiler/Parse/Expression.hs+31−29

@@ -11,39 +11,41 @@ import Parse.Literal

11import qualified Parse.Pattern as Pattern

12import qualified Parse.Type as Type

13

14−import SourceSyntax.Annotation as Annotation

14+import AST.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as P

15+import AST.Expression.General

16+import qualified AST.Expression.Source as Source

17+import qualified AST.Literal as L

18+import qualified AST.Pattern as P

16−import qualified SourceSyntax.Literal as L

19+import qualified AST.Variable as Var

17−import SourceSyntax.Expression

18

20

19

21

20-------- Basic Terms --------

22-------- Basic Terms --------

21

23

22−varTerm :: IParser ParseExpr'

24+varTerm :: IParser Source.Expr'

23varTerm = toVar <$> var <?> "variable"

25varTerm = toVar <$> var <?> "variable"

24

26

25−toVar :: String -> ParseExpr'

27+toVar :: String -> Source.Expr'

26toVar v = case v of "True" -> Literal (L.Boolean True)

28toVar v = case v of "True" -> Literal (L.Boolean True)

27 "False" -> Literal (L.Boolean False)

29 "False" -> Literal (L.Boolean False)

28 _ -> rawVar v

30 _ -> rawVar v

29

31

30−accessor :: IParser ParseExpr'

32+accessor :: IParser Source.Expr'

31accessor = do

33accessor = do

32 (start, lbl, end) <- located (try (string "." >> rLabel))

34 (start, lbl, end) <- located (try (string "." >> rLabel))

33 let loc e = Annotation.at start end e

35 let loc e = Annotation.at start end e

34 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

36 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

35

37

36−negative :: IParser ParseExpr'

38+negative :: IParser Source.Expr'

37negative = do

39negative = do

38 (start, nTerm, end) <-

40 (start, nTerm, end) <-

39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

41 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

40 let loc e = Annotation.at start end e

42 let loc e = Annotation.at start end e

41− return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)

43+ return (Binop (Var.Raw "-") (loc $ Literal (L.IntNum 0)) nTerm)

42

44

43

45

44-------- Complex Terms --------

46-------- Complex Terms --------

45

47

46−listTerm :: IParser ParseExpr'

48+listTerm :: IParser Source.Expr'

47listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

49listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

48 where

50 where

49 range = do

51 range = do

@@ -73,14 +75,14 @@ listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> comm

73 string "}}"

75 string "}}"

74 return (span uid (length exprs), exprs ++ [e])

76 return (span uid (length exprs), exprs ++ [e])

75

77

76−parensTerm :: IParser ParseExpr

78+parensTerm :: IParser Source.Expr

77parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

79parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

78 where

80 where

79 opFn = do

81 opFn = do

80 (start, op, end) <- located anyOp

82 (start, op, end) <- located anyOp

81 let loc = Annotation.at start end

83 let loc = Annotation.at start end

82 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

84 return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $

83− Binop op (loc $ rawVar "x") (loc $ rawVar "y")

85+ Binop (Var.Raw op) (loc (rawVar "x")) (loc (rawVar "y"))

84

86

85 tupleFn = do

87 tupleFn = do

86 let comma = char ',' <?> "comma ','"

88 let comma = char ',' <?> "comma ','"

@@ -96,7 +98,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

96 [e] -> e

98 [e] -> e

97 _ -> Annotation.at start end (tuple es)

99 _ -> Annotation.at start end (tuple es)

98

100

99−recordTerm :: IParser ParseExpr

101+recordTerm :: IParser Source.Expr

100recordTerm = brackets $ choice [ misc, addLocation record ]

102recordTerm = brackets $ choice [ misc, addLocation record ]

101 where

103 where

102 field = do

104 field = do

@@ -130,14 +132,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

130 Nothing -> try (insert record) <|> try (modify record)

132 Nothing -> try (insert record) <|> try (modify record)

131

133

132

134

133−term :: IParser ParseExpr

135+term :: IParser Source.Expr

134term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

136term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

135 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

136 <?> "basic term (4, x, 'c', etc.)"

138 <?> "basic term (4, x, 'c', etc.)"

137

139

138-------- Applications --------

140-------- Applications --------

139

141

140−appExpr :: IParser ParseExpr

142+appExpr :: IParser Source.Expr

141appExpr = do

143appExpr = do

142 t <- term

144 t <- term

143 ts <- constrainedSpacePrefix term $ \str ->

145 ts <- constrainedSpacePrefix term $ \str ->

@@ -148,12 +150,12 @@ appExpr = do

148

150

149-------- Normal Expressions --------

151-------- Normal Expressions --------

150

152

151−binaryExpr :: IParser ParseExpr

153+binaryExpr :: IParser Source.Expr

152binaryExpr = binops appExpr lastExpr anyOp

154binaryExpr = binops appExpr lastExpr anyOp

153 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

155 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

154 <|> lambdaExpr

156 <|> lambdaExpr

155

157

156−ifExpr :: IParser ParseExpr'

158+ifExpr :: IParser Source.Expr'

157ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

159ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

158 where

160 where

159 normal = do

161 normal = do

@@ -169,7 +171,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

169 b <- expr ; padded arrow

171 b <- expr ; padded arrow

170 (,) b <$> expr

172 (,) b <$> expr

171

173

172−lambdaExpr :: IParser ParseExpr

174+lambdaExpr :: IParser Source.Expr

173lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

175lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

174 whitespace

176 whitespace

175 args <- spaceSep1 Pattern.term

177 args <- spaceSep1 Pattern.term

@@ -177,17 +179,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

177 body <- expr

179 body <- expr

178 return (makeFunction args body)

180 return (makeFunction args body)

179

181

180−defSet :: IParser [ParseDef]

182+defSet :: IParser [Source.Def]

181defSet = block (do d <- def ; whitespace ; return d)

183defSet = block (do d <- def ; whitespace ; return d)

182

184

183−letExpr :: IParser ParseExpr'

185+letExpr :: IParser Source.Expr'

184letExpr = do

186letExpr = do

185 reserved "let" ; whitespace

187 reserved "let" ; whitespace

186 defs <- defSet

188 defs <- defSet

187 padded (reserved "in")

189 padded (reserved "in")

188 Let defs <$> expr

190 Let defs <$> expr

189

191

190−caseExpr :: IParser ParseExpr'

192+caseExpr :: IParser Source.Expr'

191caseExpr = do

193caseExpr = do

192 reserved "case"; e <- padded expr; reserved "of"; whitespace

194 reserved "case"; e <- padded expr; reserved "of"; whitespace

193 Case e <$> (with <|> without)

195 Case e <$> (with <|> without)

@@ -197,13 +199,13 @@ caseExpr = do

197 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

199 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

198 without = block (do c <- case_ ; whitespace ; return c)

200 without = block (do c <- case_ ; whitespace ; return c)

199

201

200−expr :: IParser ParseExpr

202+expr :: IParser Source.Expr

201expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

203expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

202 <|> lambdaExpr

204 <|> lambdaExpr

203 <|> binaryExpr

205 <|> binaryExpr

204 <?> "an expression"

206 <?> "an expression"

205

207

206−defStart :: IParser [P.Pattern]

208+defStart :: IParser [P.RawPattern]

207defStart =

209defStart =

208 choice [ do p1 <- try Pattern.term

210 choice [ do p1 <- try Pattern.term

209 infics p1 <|> func p1

211 infics p1 <|> func p1

@@ -223,24 +225,24 @@ defStart =

223 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

225 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

224 else [ P.Var (o:p), p1, p2 ]

226 else [ P.Var (o:p), p1, p2 ]

225

227

226−makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr

228+makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

227makeFunction args body@(A ann _) =

229makeFunction args body@(A ann _) =

228 foldr (\arg body' -> A ann $ Lambda arg body') body args

230 foldr (\arg body' -> A ann $ Lambda arg body') body args

229

231

230−definition :: IParser ParseDef

232+definition :: IParser Source.Def

231definition = withPos $ do

233definition = withPos $ do

232 (name:args) <- defStart

234 (name:args) <- defStart

233 padded equals

235 padded equals

234 body <- expr

236 body <- expr

235− return . Def name $ makeFunction args body

237+ return . Source.Definition name $ makeFunction args body

236

238

237−typeAnnotation :: IParser ParseDef

239+typeAnnotation :: IParser Source.Def

238−typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

240+typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr

239 where

241 where

240 start = do

242 start = do

241 v <- lowVar <|> parens symOp

243 v <- lowVar <|> parens symOp

242 padded hasType

244 padded hasType

243 return v

245 return v

244

246

245−def :: IParser ParseDef

247+def :: IParser Source.Def

246def = typeAnnotation <|> definition

248def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+11−28

@@ -6,7 +6,6 @@ import Control.Applicative ((<$>),(<*>))

6import Control.Monad

7import Control.Monad.State

8import Data.Char (isUpper)

9−import qualified Data.Set as Set

10import qualified Data.Map as Map

9import qualified Data.Map as Map

11import qualified Language.GLSL.Parser as GLP

10import qualified Language.GLSL.Parser as GLP

12import Language.GLSL.Syntax as GLS

11import Language.GLSL.Syntax as GLS

@@ -14,13 +13,14 @@ import Text.Parsec hiding (newline,spaces,State)

14import Text.Parsec.Indent

13import Text.Parsec.Indent

15import qualified Text.Parsec.Token as T

14import qualified Text.Parsec.Token as T

16

15

17−import SourceSyntax.Annotation as Annotation

16+import AST.Annotation as Annotation

18−import SourceSyntax.Declaration (Assoc)

17+import AST.Declaration (Assoc)

19−import SourceSyntax.Expression

18+import AST.Expression.General

19+import qualified AST.Expression.Source as Source

20−import SourceSyntax.Helpers as Help

20+import AST.Helpers as Help

21−import SourceSyntax.Literal as Literal

21+import AST.Literal as Literal

22−import SourceSyntax.PrettyPrint

22+import AST.PrettyPrint

23−import SourceSyntax.Variable as Variable

23+import qualified AST.Variable as Variable

24

25reserveds = [ "if", "then", "else"

26 , "case", "of"

@@ -29,25 +29,8 @@ reserveds = [ "if", "then", "else"

29 , "module", "where"

30 , "import", "as", "hiding", "open"

31 , "export", "foreign"

32− , "deriving", "port" ]

32+ , "deriving", "port"

33−

34−jsReserveds :: Set.Set String

35−jsReserveds = Set.fromList

36− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"

37− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"

38− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"

39− , "transient", "synchronized", "function", "break", "case", "catch"

40− , "continue", "debugger", "default", "delete", "do", "else", "finally"

41− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"

42− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"

43− , "const", "enum", "export", "extends", "import", "super", "implements"

44− , "interface", "let", "package", "private", "protected", "public"

45− , "static", "yield"

46− -- reserved by the Elm runtime system

47− , "Elm", "ElmRuntime"

48− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"

49− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"

50− ]

33+ ]

51

34

52expecting = flip (<?>)

35expecting = flip (<?>)

53

36

@@ -200,7 +183,7 @@ located p = do

200 end <- getPosition

183 end <- getPosition

201 return (start, e, end)

184 return (start, e, end)

202

185

203−accessible :: IParser ParseExpr -> IParser ParseExpr

186+accessible :: IParser Source.Expr -> IParser Source.Expr

204accessible expr = do

187accessible expr = do

205 start <- getPosition

188 start <- getPosition

206 ce@(A _ e) <- expr

189 ce@(A _ e) <- expr

compiler/Parse/Literal.hs+1−1

@@ -4,7 +4,7 @@ module Parse.Literal (literal) where

4import Control.Applicative ((<$>))

5import Text.Parsec hiding (newline,spaces)

6import Parse.Helpers

7−import SourceSyntax.Literal

7+import AST.Literal

8

9literal :: IParser Literal

10literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"

compiler/Parse/Module.hs+31−14

@@ -5,10 +5,8 @@ import Data.List (intercalate)

5import Text.Parsec hiding (newline,spaces)

6

7import Parse.Helpers

8−import SourceSyntax.Module (ImportMethod(..), Imports)

8+import AST.Module (ImportMethod(..))

9−

9+import AST.Variable (Listing(..), Value(..), openListing)

10−varList :: IParser [String]

11−varList = commaSep1 (var <|> parens symOp)

12

10

13getModuleName :: String -> Maybe String

11getModuleName :: String -> Maybe String

14getModuleName source =

12getModuleName source =

@@ -21,18 +19,18 @@ getModuleName source =

21 (names, _) <- moduleDef

19 (names, _) <- moduleDef

22 return (intercalate "." names)

20 return (intercalate "." names)

23

21

24−moduleDef :: IParser ([String], [String])

22+moduleDef :: IParser ([String], Listing Value)

25moduleDef = do

23moduleDef = do

26 try (reserved "module")

24 try (reserved "module")

27 whitespace

25 whitespace

28 names <- dotSep1 capVar <?> "name of module"

26 names <- dotSep1 capVar <?> "name of module"

29 whitespace

27 whitespace

30− exports <- option [] (parens varList)

28+ exports <- option (Listing [] True) (listing value)

31 whitespace <?> "reserved word 'where'"

29 whitespace <?> "reserved word 'where'"

32 reserved "where"

30 reserved "where"

33 return (names, exports)

31 return (names, exports)

34

32

35−imports :: IParser Imports

33+imports :: IParser [(String, ImportMethod)]

36imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

34imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

37

35

38import' :: IParser (String, ImportMethod)

36import' :: IParser (String, ImportMethod)

@@ -43,17 +41,36 @@ import' =

43 (,) name <$> option (As name) method

41 (,) name <$> option (As name) method

44 where

42 where

45 method :: IParser ImportMethod

43 method :: IParser ImportMethod

46− method = try $ do whitespace

47− as' <|> importing'

44+ method = as' <|> importing'

48

45

49 as' :: IParser ImportMethod

46 as' :: IParser ImportMethod

50 as' = do

47 as' = do

51− reserved "as"

48+ try (whitespace >> reserved "as")

52 whitespace

49 whitespace

53 As <$> capVar <?> "alias for module"

50 As <$> capVar <?> "alias for module"

54

51

55 importing' :: IParser ImportMethod

52 importing' :: IParser ImportMethod

56− importing' =

53+ importing' = Open <$> listing value

54+

55+listing :: IParser a -> IParser (Listing a)

56+listing item =

57+ do try (whitespace >> char '(')

58+ whitespace

57− parens (choice [ const (Hiding []) <$> string ".."

59+ listing <- choice [ const openListing <$> string ".."

58− , Importing <$> varList

60+ , Listing <$> commaSep1 item <*> return False

59− ] <?> "listing of imported values (x,y,z)")

61+ ] <?> "listing of values (x,y,z)"

62+ whitespace

63+ char ')'

64+ return listing

65+

66+value :: IParser Value

67+value = val <|> tipe

68+ where

69+ val = Value <$> (lowVar <|> parens symOp)

70+

71+ tipe = do

72+ name <- capVar

73+ maybeCtors <- optionMaybe (listing capVar)

74+ case maybeCtors of

75+ Nothing -> return (Alias name)

76+ Just ctors -> return (ADT name ctors)

compiler/Parse/Parse.hs+13−9

@@ -7,8 +7,9 @@ import qualified Data.Map as Map

7import Text.Parsec hiding (newline,spaces)

8import qualified Text.PrettyPrint as P

9

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11−import qualified SourceSyntax.Module as M

11+import qualified AST.Module as M

12+import qualified AST.Variable as Var

12import Parse.Helpers

13import Parse.Helpers

13import Parse.Declaration (infixDecl)

14import Parse.Declaration (infixDecl)

14import Parse.Module

15import Parse.Module

@@ -22,21 +23,24 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

23decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

23 (d:) <$> many freshDef

24 (d:) <$> many freshDef

24

25

25−program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program :: OpTable -> String -> Either [P.Doc] M.ValidModule

26program table src =

27program table src =

28+ do (M.Module names filePath exs ims parseDecls) <-

27− do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

29+ setupParserWithTable table programParser src

30+ decls <-

28− decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

31+ either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29− return $ M.Module names exs ims decls

32+ return $ M.Module names filePath exs ims decls

30

33

31−programParser :: IParser (M.Module D.ParseDeclaration)

34+programParser :: IParser M.SourceModule

32programParser =

35programParser =

33 do optional freshLine

36 do optional freshLine

37+ (names,exports) <-

34− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

38+ option (["Main"], Var.openListing) (moduleDef `followedBy` freshLine)

35 is <- (do try (lookAhead $ reserved "import")

39 is <- (do try (lookAhead $ reserved "import")

36 imports `followedBy` freshLine) <|> return []

40 imports `followedBy` freshLine) <|> return []

37 declarations <- decls

41 declarations <- decls

38 optional freshLine ; optional spaces ; eof

42 optional freshLine ; optional spaces ; eof

39− return $ M.Module names exports is declarations

43+ return $ M.Module names "" exports is declarations

40

44

41dependencies :: String -> Either [P.Doc] (String, [String])

45dependencies :: String -> Either [P.Doc] (String, [String])

42dependencies =

46dependencies =

compiler/Parse/Pattern.hs+13−12

@@ -8,54 +8,55 @@ import Text.Parsec hiding (newline,spaces,State)

8

9import Parse.Helpers

10import Parse.Literal

11−import SourceSyntax.Literal

11+import AST.Literal

12−import qualified SourceSyntax.Pattern as P

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

13

14

14−basic :: IParser P.Pattern

15+basic :: IParser P.RawPattern

15basic = choice

16basic = choice

16 [ char '_' >> return P.Anything

17 [ char '_' >> return P.Anything

17 , do v <- var

18 , do v <- var

18 return $ case v of

19 return $ case v of

19 "True" -> P.Literal (Boolean True)

20 "True" -> P.Literal (Boolean True)

20 "False" -> P.Literal (Boolean False)

21 "False" -> P.Literal (Boolean False)

21− c:_ | isUpper c -> P.Data v []

22+ c:_ | isUpper c -> P.Data (Var.Raw v) []

22 _ -> P.Var v

23 _ -> P.Var v

23 , P.Literal <$> literal

24 , P.Literal <$> literal

24 ]

25 ]

25

26

26−asPattern :: P.Pattern -> IParser P.Pattern

27+asPattern :: P.RawPattern -> IParser P.RawPattern

27asPattern pattern = do

28asPattern pattern = do

28 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

29 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

29 return $ case var of

30 return $ case var of

30 Just v -> P.Alias v pattern

31 Just v -> P.Alias v pattern

31 Nothing -> pattern

32 Nothing -> pattern

32

33

33−record :: IParser P.Pattern

34+record :: IParser P.RawPattern

34record = P.Record <$> brackets (commaSep1 lowVar)

35record = P.Record <$> brackets (commaSep1 lowVar)

35

36

36−tuple :: IParser P.Pattern

37+tuple :: IParser P.RawPattern

37tuple = do

38tuple = do

38 ps <- parens (commaSep expr)

39 ps <- parens (commaSep expr)

39 return $ case ps of

40 return $ case ps of

40 [p] -> p

41 [p] -> p

41 _ -> P.tuple ps

42 _ -> P.tuple ps

42

43

43−list :: IParser P.Pattern

44+list :: IParser P.RawPattern

44list = P.list <$> braces (commaSep expr)

45list = P.list <$> braces (commaSep expr)

45

46

46−term :: IParser P.Pattern

47+term :: IParser P.RawPattern

47term =

48term =

48 (choice [ record, tuple, list, basic ]) <?> "pattern"

49 (choice [ record, tuple, list, basic ]) <?> "pattern"

49

50

50−patternConstructor :: IParser P.Pattern

51+patternConstructor :: IParser P.RawPattern

51patternConstructor = do

52patternConstructor = do

52 v <- List.intercalate "." <$> dotSep1 capVar

53 v <- List.intercalate "." <$> dotSep1 capVar

53 case v of

54 case v of

54 "True" -> return $ P.Literal (Boolean True)

55 "True" -> return $ P.Literal (Boolean True)

55 "False" -> return $ P.Literal (Boolean False)

56 "False" -> return $ P.Literal (Boolean False)

56− _ -> P.Data v <$> spacePrefix term

57+ _ -> P.Data (Var.Raw v) <$> spacePrefix term

57

58

58−expr :: IParser P.Pattern

59+expr :: IParser P.RawPattern

59expr = do

60expr = do

60 patterns <- consSep1 (patternConstructor <|> term)

61 patterns <- consSep1 (patternConstructor <|> term)

61 asPattern (foldr1 P.cons patterns) <?> "pattern"

62 asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/Parse/Type.hs+21−17

@@ -5,22 +5,23 @@ import Control.Applicative ((<$>),(<*>),(<*))

5import Data.List (intercalate)

6import Text.Parsec

7

8−import SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

9import Parse.Helpers

10import Parse.Helpers

10

11

11−tvar :: IParser T.Type

12+tvar :: IParser T.RawType

12tvar = T.Var <$> lowVar <?> "type variable"

13tvar = T.Var <$> lowVar <?> "type variable"

13

14

14−list :: IParser T.Type

15+list :: IParser T.RawType

15−list = listOf <$> braces expr

16+list = T.listOf <$> braces expr

16

17

17−tuple :: IParser T.Type

18+tuple :: IParser T.RawType

18tuple = do ts <- parens (commaSep expr)

19tuple = do ts <- parens (commaSep expr)

19 return $ case ts of

20 return $ case ts of

20 [t] -> t

21 [t] -> t

21− _ -> tupleOf ts

22+ _ -> T.tupleOf ts

22

23

23−record :: IParser T.Type

24+record :: IParser T.RawType

24record =

25record =

25 do char '{' ; whitespace

26 do char '{' ; whitespace

26 rcrd <- extended <|> normal

27 rcrd <- extended <|> normal

@@ -33,7 +34,7 @@ record =

33 extended = do

34 extended = do

34 ext <- try (lowVar <* (whitespace >> string "|"))

35 ext <- try (lowVar <* (whitespace >> string "|"))

35 whitespace

36 whitespace

36− flip T.Record (Just ext) <$> commaSep1 field

37+ flip T.Record (Just (T.Var ext)) <$> commaSep1 field

37

38

38 field = do

39 field = do

39 lbl <- rLabel

40 lbl <- rLabel

@@ -43,25 +44,28 @@ record =

43capTypeVar :: IParser String

44capTypeVar :: IParser String

44capTypeVar = intercalate "." <$> dotSep1 capVar

45capTypeVar = intercalate "." <$> dotSep1 capVar

45

46

46−constructor0 :: IParser T.Type

47+constructor0 :: IParser T.RawType

47constructor0 =

48constructor0 =

48 do name <- capTypeVar

49 do name <- capTypeVar

49− return (T.Data name [])

50+ return (T.Type (Var.Raw name))

50

51

51−term :: IParser T.Type

52+term :: IParser T.RawType

52term = list <|> tuple <|> record <|> tvar <|> constructor0

53term = list <|> tuple <|> record <|> tvar <|> constructor0

53

54

54−app :: IParser T.Type

55+app :: IParser T.RawType

55app =

56app =

56− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

57+ do f <- constructor0 <|> try tupleCtor <?> "type constructor"

57 args <- spacePrefix term

58 args <- spacePrefix term

58− return (T.Data name args)

59+ return $ case args of

60+ [] -> f

61+ _ -> T.App f args

59 where

62 where

60 tupleCtor = do

63 tupleCtor = do

61 n <- length <$> parens (many (char ','))

64 n <- length <$> parens (many (char ','))

62− return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)

65+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

66+ return (T.Type (Var.Raw ctor))

63

67

64−expr :: IParser T.Type

68+expr :: IParser T.RawType

65expr =

69expr =

66 do t1 <- app <|> term

70 do t1 <- app <|> term

67 arr <- optionMaybe $ try (whitespace >> arrow)

71 arr <- optionMaybe $ try (whitespace >> arrow)

@@ -69,6 +73,6 @@ expr =

69 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

73 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

70 Nothing -> return t1

74 Nothing -> return t1

71

75

72−constructor :: IParser (String, [T.Type])

76+constructor :: IParser (String, [T.RawType])

73constructor = (,) <$> (capTypeVar <?> "another type constructor")

77constructor = (,) <$> (capTypeVar <?> "another type constructor")

74 <*> spacePrefix term

78 <*> spacePrefix term

compiler/SourceSyntax/Module.hsdeleted−119

@@ -1,119 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Module where

3−

4−import Data.Binary

5−import qualified Data.List as List

6−import qualified Data.Map as Map

7−import Control.Applicative ((<$>), (<*>))

8−import Text.PrettyPrint as P

9−

10−import SourceSyntax.Expression (Expr)

11−import SourceSyntax.Declaration

12−import SourceSyntax.PrettyPrint

13−import SourceSyntax.Type

14−

15−import qualified Elm.Internal.Version as Version

16−

17−data Module def =

18− Module [String] Exports Imports [def]

19− deriving (Show)

20−

21−type Exports = [String]

22−

23−type Imports = [(String, ImportMethod)]

24−data ImportMethod = As String | Importing [String] | Hiding [String]

25− deriving (Eq, Ord, Show)

26−

27−instance (Pretty def) => Pretty (Module def) where

28− pretty (Module modNames exports imports decls) =

29− P.vcat [modul, P.text "", prettyImports, P.text "", prettyDecls]

30− where

31− prettyDecls = P.sep $ map pretty decls

32−

33− modul = P.text "module" <+> moduleName <+> prettyExports <+> P.text "where"

34− moduleName = P.text $ List.intercalate "." modNames

35− prettyExports =

36− case exports of

37− [] -> P.empty

38− _ -> P.parens . commaCat $ map P.text exports

39−

40− prettyImports = P.vcat $ map prettyImport imports

41−

42− prettyImport (name, method) =

43− P.text "import" <+>

44− case method of

45− As alias ->

46− P.text $ name ++ (if name == alias then "" else " as " ++ alias)

47−

48− Importing values ->

49− P.text name <+> P.parens (commaCat (map P.text values))

50−

51− Hiding [] -> P.text ("open " ++ name)

52− Hiding _ -> error "invalid import declaration"

53−

54−instance Binary ImportMethod where

55− put method =

56− let put' n info = putWord8 n >> put info in

57− case method of

58− As s -> put' 0 s

59− Importing ss -> put' 1 ss

60− Hiding ss -> put' 2 ss

61−

62− get = do tag <- getWord8

63− case tag of

64− 0 -> As <$> get

65− 1 -> Importing <$> get

66− 2 -> Hiding <$> get

67− _ -> error "Error reading valid ImportMethod type from serialized string"

68−

69−data MetadataModule =

70− MetadataModule

71− { names :: [String]

72− , path :: FilePath

73− , exports :: [String]

74− , imports :: [(String, ImportMethod)]

75− , program :: Expr

76− , types :: Map.Map String Type

77− , fixities :: [(Assoc, Int, String)]

78− , aliases :: [Alias]

79− , datatypes :: [ADT]

80− , ports :: [String]

81− } deriving Show

82−

83−type Interfaces = Map.Map String ModuleInterface

84−type ADT = (String, [String], [(String,[Type])])

85−type Alias = (String, [String], Type)

86−

87−data ModuleInterface =

88− ModuleInterface

89− { iVersion :: Version.Version

90− , iTypes :: Map.Map String Type

91− , iImports :: [(String, ImportMethod)]

92− , iAdts :: [ADT]

93− , iAliases :: [Alias]

94− , iFixities :: [(Assoc, Int, String)]

95− , iPorts :: [String]

96− } deriving Show

97−

98−metaToInterface :: MetadataModule -> ModuleInterface

99−metaToInterface metaModule =

100− ModuleInterface

101− { iVersion = Version.elmVersion

102− , iTypes = types metaModule

103− , iImports = imports metaModule

104− , iAdts = datatypes metaModule

105− , iAliases = aliases metaModule

106− , iFixities = fixities metaModule

107− , iPorts = ports metaModule

108− }

109−

110−instance Binary ModuleInterface where

111− get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get <*> get

112− put modul = do

113− put (iVersion modul)

114− put (iTypes modul)

115− put (iImports modul)

116− put (iAdts modul)

117− put (iAliases modul)

118− put (iFixities modul)

119− put (iPorts modul)

compiler/SourceSyntax/Pattern.hsdeleted−69

@@ -1,69 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Pattern where

3−

4−import qualified SourceSyntax.Helpers as Help

5−import SourceSyntax.PrettyPrint

6−import Text.PrettyPrint as PP

7−import qualified Data.Set as Set

8−import SourceSyntax.Literal as Literal

9−

10−data Pattern

11− = Data String [Pattern]

12− | Record [String]

13− | Alias String Pattern

14− | Var String

15− | Anything

16− | Literal Literal.Literal

17− deriving (Eq, Ord, Show)

18−

19−cons :: Pattern -> Pattern -> Pattern

20−cons h t = Data "::" [h,t]

21−

22−nil :: Pattern

23−nil = Data "[]" []

24−

25−list :: [Pattern] -> Pattern

26−list = foldr cons nil

27−

28−tuple :: [Pattern] -> Pattern

29−tuple es = Data ("_Tuple" ++ show (length es)) es

30−

31−boundVarList :: Pattern -> [String]

32−boundVarList = Set.toList . boundVars

33−

34−boundVars :: Pattern -> Set.Set String

35−boundVars pattern =

36− case pattern of

37− Var x -> Set.singleton x

38− Alias x p -> Set.insert x (boundVars p)

39− Data _ ps -> Set.unions (map boundVars ps)

40− Record fields -> Set.fromList fields

41− Anything -> Set.empty

42− Literal _ -> Set.empty

43−

44−

45−instance Pretty Pattern where

46− pretty pattern =

47− case pattern of

48− Var x -> variable x

49− Literal lit -> pretty lit

50− Record fs -> PP.braces (commaCat $ map variable fs)

51− Alias x p -> prettyParens p <+> PP.text "as" <+> variable x

52− Anything -> PP.text "_"

53− Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

54− where isCons = case hd of

55− Data "::" _ -> True

56− _ -> False

57− Data name ps ->

58− if Help.isTuple name then

59− PP.parens . commaCat $ map pretty ps

60− else hsep (PP.text name : map prettyParens ps)

61−

62−prettyParens :: Pattern -> Doc

63−prettyParens pattern = parensIf needsThem (pretty pattern)

64− where

65− needsThem =

66− case pattern of

67− Data name (_:_) | not (Help.isTuple name) -> True

68− Alias _ _ -> True

69− _ -> False

compiler/SourceSyntax/Type.hsdeleted−89

@@ -1,89 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Type where

3−

4−import Control.Applicative ((<$>), (<*>))

5−import Data.Binary

6−import qualified Data.Map as Map

7−import SourceSyntax.PrettyPrint

8−import qualified SourceSyntax.Helpers as Help

9−import Text.PrettyPrint as P

10−

11−data Type = Lambda Type Type

12− | Var String

13− | Data String [Type]

14− | Record [(String,Type)] (Maybe String)

15− deriving (Eq,Show)

16−

17−fieldMap :: [(String,a)] -> Map.Map String [a]

18−fieldMap fields =

19− foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

20−

21−recordOf :: [(String,Type)] -> Type

22−recordOf fields = Record fields Nothing

23−

24−listOf :: Type -> Type

25−listOf t = Data "_List" [t]

26−

27−tupleOf :: [Type] -> Type

28−tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

29−

30−instance Pretty Type where

31− pretty tipe =

32− case tipe of

33− Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

34− where

35− t:ts = map prettyLambda (collectLambdas tipe)

36− prettyLambda t = case t of

37− Lambda _ _ -> P.parens (pretty t)

38− _ -> pretty t

39−

40− Var x -> P.text x

41− Data "_List" [t] -> P.brackets (pretty t)

42− Data name tipes

43− | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

44− | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

45− Record fields ext ->

46− P.braces $ case ext of

47− Nothing -> prettyFields

48− Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields

49− where

50− prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

51− prettyFields = commaSep . map prettyField $ fields

52−

53−collectLambdas :: Type -> [Type]

54−collectLambdas tipe =

55− case tipe of

56− Lambda arg body -> arg : collectLambdas body

57− _ -> [tipe]

58−

59−prettyParens :: Type -> Doc

60−prettyParens tipe = parensIf needed (pretty tipe)

61− where

62− needed =

63− case tipe of

64− Lambda _ _ -> True

65− Data "_List" [_] -> False

66− Data _ [] -> False

67− Data _ _ -> True

68− _ -> False

69−

70−instance Binary Type where

71− put tipe =

72− case tipe of

73− Lambda t1 t2 ->

74− putWord8 0 >> put t1 >> put t2

75− Var x ->

76− putWord8 1 >> put x

77− Data ctor tipes ->

78− putWord8 2 >> put ctor >> put tipes

79− Record fs ext ->

80− putWord8 3 >> put fs >> put ext

81−

82− get = do

83− n <- getWord8

84− case n of

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

86− 1 -> Var <$> get

87− 2 -> Data <$> get <*> get

88− 3 -> Record <$> get <*> get

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

compiler/SourceSyntax/Variable.hsdeleted−11

@@ -1,11 +0,0 @@

1−

2−module SourceSyntax.Variable where

3−

4−import qualified Text.PrettyPrint as P

5−import SourceSyntax.PrettyPrint

6−

7−newtype Raw = Raw String

8− deriving (Eq,Ord,Show)

9−

10−instance Pretty Raw where

11− pretty (Raw var) = variable var

compiler/Transform/Canonicalize.hs+228−162

@@ -1,192 +1,258 @@

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2−module Transform.Canonicalize (interface, metadataModule) where

2+module Transform.Canonicalize (module', filterExports) where

3

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

4+import Control.Applicative ((<$>),(<*>))

5−import Control.Applicative (Applicative,(<$>),(<*>))

6−import Control.Monad.Identity

5+import Control.Monad.Error (runErrorT, throwError)

7−import qualified Data.Either as Either

6+import Control.Monad.State (runState)

8import qualified Data.List as List

7import qualified Data.List as List

9import qualified Data.Map as Map

8import qualified Data.Map as Map

10import qualified Data.Set as Set

9import qualified Data.Set as Set

11import qualified Data.Traversable as T

10import qualified Data.Traversable as T

11+

12+import AST.Expression.General (Expr'(..), dummyLet)

13+import qualified AST.Expression.Valid as Valid

14+import qualified AST.Expression.Canonical as Canonical

15+

16+import AST.Module (CanonicalBody(..))

17+import qualified AST.Module as Module

18+import qualified AST.Type as Type

19+import qualified AST.Variable as Var

12−import SourceSyntax.Annotation as A

20+import qualified AST.Annotation as A

13−import SourceSyntax.Expression

21+import qualified AST.Declaration as D

14−import SourceSyntax.Module

15−import SourceSyntax.PrettyPrint (pretty)

22+import AST.PrettyPrint (pretty, commaSep)

16−import qualified SourceSyntax.Pattern as P

23+import qualified AST.Pattern as P

17−import qualified SourceSyntax.Type as Type

18−import qualified SourceSyntax.Variable as Var

19import Text.PrettyPrint as P

24import Text.PrettyPrint as P

20

25

21−interface :: String -> ModuleInterface -> ModuleInterface

26+import Transform.Canonicalize.Environment as Env

22−interface moduleName iface =

27+import qualified Transform.Canonicalize.Setup as Setup

23− ModuleInterface

28+import qualified Transform.Canonicalize.Type as Canonicalize

24− { iVersion = iVersion iface

29+import qualified Transform.Canonicalize.Variable as Canonicalize

25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

30+import qualified Transform.SortDefinitions as Transform

26− , iImports = iImports iface

31+import qualified Transform.Declaration as Transform

27− , iAdts = map (both prefix renameCtors) (iAdts iface)

32+

28− , iAliases = map (both prefix renameType') (iAliases iface)

33+module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule

29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

34+module' interfaces modul =

30− , iPorts = iPorts iface

35+ filterImports <$> modul'

36+ where

37+ (modul', usedModules) =

38+ runState (runErrorT (moduleHelp interfaces modul)) Set.empty

39+

40+ filterImports m =

41+ let used (name,_) = Set.member name usedModules

42+ in m { Module.imports = filter used (Module.imports m) }

43+

44+moduleHelp :: Module.Interfaces -> Module.ValidModule

45+ -> Canonicalizer [Doc] Module.CanonicalModule

46+moduleHelp interfaces modul@(Module.Module _ _ exs _ decls) =

47+ do env <- Setup.environment interfaces modul

48+ canonicalDecls <- mapM (declaration env) decls

49+ exports' <- delist locals exs

50+ return $ modul { Module.exports = exports'

51+ , Module.body = body canonicalDecls

31− }

52+ }

32 where

53 where

33− both f g (a,b,c) = (f a, b, g c)

54+ locals :: [Var.Value]

34− prefix name = moduleName ++ "." ++ name

55+ locals = concatMap declToValue decls

35−

56+

36− pair name = (name, moduleName ++ "." ++ name)

57+ body :: [D.CanonicalDecl] -> Module.CanonicalBody

37− canon (name,_,_) = pair name

58+ body decls =

38− canons = Map.fromList $ concat

59+ Module.CanonicalBody

39− [ map canon (iAdts iface), map canon (iAliases iface) ]

60+ { program =

40−

61+ let expr = Transform.toExpr (Module.getName modul) decls

41− renameCtors ctors =

62+ in Transform.sortDefs (dummyLet expr)

42− map (prefix *** map renameType') ctors

63+ , types = Map.empty

43− renameType' =

64+ , datatypes =

44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

65+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

45−

66+ , fixities =

46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

67+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

47−renameType renamer tipe =

68+ , aliases =

48− let rnm = renameType renamer in

69+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

49− case tipe of

70+ , ports =

50− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

71+ [ D.portName port | D.Port port <- decls ]

51− Type.Var _ -> return tipe

72+ }

52− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

73+

53− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

74+delist :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]

54− where rnm' (f,t) = (,) f <$> rnm t

75+delist fullList (Var.Listing partial open)

55−

76+ | open = return fullList

56−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

77+ | otherwise = go [] (List.sort fullList) (List.sort partial)

57−metadataModule ifaces modul =

78+ where

58− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

79+ notFound xs =

59− [] -> Right ()

80+ throwError [ P.text "Export Error: trying to export non-existent values:" <+>

60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++

81+ commaSep (map pretty xs)

61− "\n You may need to compile with the --make flag to detect modules you have written."

82+ ]

62− ]

83+

63− program' <- rename initialEnv (program modul)

84+ go list full partial =

64− aliases' <- mapM (three3 renameType') (aliases modul)

85+ case (full, partial) of

65− datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)

86+ (_, []) -> return list

66− return $ modul { program = program'

87+ ([], _) -> notFound partial

67− , aliases = aliases'

88+ (x:xs, y:ys) ->

68− , datatypes = datatypes' }

89+ case (x,y) of

90+ (Var.Value x', Var.Value y') | x' == y' ->

91+ go (x : list) xs ys

92+

93+ (Var.Alias x', Var.Alias y') | x' == y' ->

94+ go (x : list) xs ys

95+

96+ (Var.ADT x' _, Var.Alias y') | x' == y' ->

97+ go (Var.ADT x' (Var.Listing [] False) : list) xs ys

98+

99+ (Var.ADT x' (Var.Listing xctors _ ),

100+ Var.ADT y' (Var.Listing yctors open)) | x' == y' ->

101+ if open

102+ then go (x : list) xs ys

103+ else case filter (`notElem` xctors) yctors of

104+ [] -> go (y : list) xs ys

105+ bads -> notFound bads

106+

107+ _ -> go list xs partial

108+

109+filterExports :: Module.Types -> [Var.Value] -> Module.Types

110+filterExports types values =

111+ Map.fromList (concatMap getValue values)

69 where

112 where

70− two2 f (a,b) = (,) a <$> f b

113+ getValue :: Var.Value -> [(String, Type.CanonicalType)]

71− three3 f (a,b,c) = (,,) a b <$> f c

114+ getValue value =

72− renameType' =

115+ case value of

73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

116+ Var.Value x -> get x

74−

117+ Var.Alias x -> get x

75− get1 (a,_,_) = a

118+ Var.ADT _ (Var.Listing ctors _) -> concatMap get ctors

76− canon (name, importMethod) =

119+

77− let pair pre var = (pre ++ drop (length name + 1) var, var)

120+ get :: String -> [(String, Type.CanonicalType)]

78− iface = ifaces Map.! name

121+ get x =

79− allNames = concat [ Map.keys (iTypes iface)

80− , map get1 (iAliases iface)

81− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

82− in case importMethod of

83− As alias -> map (pair (alias ++ ".")) allNames

84− Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

85− where vs = Set.fromList vars

86− Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

87− where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

88−

89− two n = (n,n)

90− localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

91− globalEnv =

92− map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

93− map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

94− realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

95− initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

96−

97−type Env = Map.Map String String

98−

99−extend :: Env -> P.Pattern -> Env

100−extend env pattern = Map.union (Map.fromList (zip xs xs)) env

101− where xs = P.boundVarList pattern

102−

103−replace :: String -> Env -> String -> Either String String

104−replace variable env v =

105− if List.isPrefixOf "Native." v then return v else

106− case Map.lookup v env of

122+ case Map.lookup x types of

107− Just v' -> return v'

123+ Just t -> [(x,t)]

108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg

124+ Nothing -> []

125+

126+declToValue :: D.ValidDecl -> [Var.Value]

127+declToValue decl =

128+ case decl of

129+ D.Definition (Valid.Definition pattern _ _) ->

130+ map Var.Value (P.boundVarList pattern)

131+

132+ D.Datatype name _tvs ctors ->

133+ [ Var.ADT name (Var.Listing (map fst ctors) False) ]

134+

135+ D.TypeAlias name _ (Type.Record _ _) ->

136+ [ Var.Alias name ]

137+

138+ _ -> []

139+

140+declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl

141+declaration env decl =

142+ let canonicalize kind context pattern env v =

143+ let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon

144+ throw err = P.vcat [ ctx, P.text err ]

145+ in

146+ Env.onError throw (kind env v)

147+ in

148+ case decl of

149+ D.Definition (Valid.Definition p e t) ->

150+ do p' <- canonicalize pattern "definition" p env p

151+ e' <- expression env e

152+ t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t

153+ return $ D.Definition (Canonical.Definition p' e' t')

154+

155+ D.Datatype name tvars ctors ->

156+ D.Datatype name tvars <$> mapM canonicalize' ctors

109 where

157 where

110− matches = filter (List.isInfixOf v) (Map.keys env)

158+ canonicalize' (ctor,args) =

111− msg = if null matches then "" else

159+ (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

112− "\nClose matches include: " ++ List.intercalate ", " matches

160+

113−

161+ D.TypeAlias name tvars expanded ->

114−-- TODO: Var.Raw -> Var.Canonical

162+ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

115−rename :: Env -> Expr -> Either [Doc] Expr

163+ return (D.TypeAlias name tvars expanded')

164+

165+ D.Port port -> do

166+ Env.uses "Native.Ports"

167+ Env.uses "Native.Json"

168+ D.Port <$> case port of

169+ D.In name t ->

170+ do t' <- canonicalize Canonicalize.tipe "port" name env t

171+ return (D.In name t')

172+ D.Out name e t ->

173+ do e' <- expression env e

174+ t' <- canonicalize Canonicalize.tipe "port" name env t

175+ return (D.Out name e' t')

176+

177+ D.Fixity assoc prec op -> return $ D.Fixity assoc prec op

178+

179+

180+expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr

116−rename env (A ann expr) =

181+expression env (A.A ann expr) =

117− let rnm = rename env

182+ let go = expression env

183+ tipe' environ = format . Canonicalize.tipe environ

118− throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon

184+ throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon

119− , P.text err

185+ , P.text err ]

120− ]

121− ]

122− format = Either.either throw return

186+ format = Env.onError throw

123− renameType' environ = renameType (format . replace "variable" environ)

124 in

187 in

125− A ann <$>

188+ A.A ann <$>

126 case expr of

189 case expr of

127− Literal _ -> return expr

190+ Literal lit -> return (Literal lit)

128

191

129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

192+ Range e1 e2 -> Range <$> go e1 <*> go e2

130

193

131− Access e x -> Access <$> rnm e <*> return x

194+ Access e x -> Access <$> go e <*> return x

132

195

133− Remove e x -> flip Remove x <$> rnm e

196+ Remove e x -> flip Remove x <$> go e

134

197

135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v

198+ Insert e x v -> flip Insert x <$> go e <*> go v

136

199

137 Modify e fs ->

200 Modify e fs ->

138− Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs

201+ Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs

139

202

140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

203+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs

141

204

142− Binop op e1 e2 ->

205+ Binop (Var.Raw op) e1 e2 ->

143− do op' <- format (replace "variable" env op)

206+ do op' <- format (Canonicalize.variable env op)

144− Binop op' <$> rnm e1 <*> rnm e2

207+ Binop op' <$> go e1 <*> go e2

145

208

146− Lambda pattern e ->

209+ Lambda p e ->

147− let env' = extend env pattern in

210+ let env' = update p env in

148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e

211+ Lambda <$> format (pattern env' p) <*> expression env' e

149

212

150− App e1 e2 -> App <$> rnm e1 <*> rnm e2

213+ App e1 e2 -> App <$> go e1 <*> go e2

151

214

152− MultiIf ps -> MultiIf <$> mapM grnm ps

215+ MultiIf ps -> MultiIf <$> mapM go' ps

153− where grnm (b,e) = (,) <$> rnm b <*> rnm e

216+ where go' (b,e) = (,) <$> go b <*> go e

154

217

155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e

218+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e

156 where

219 where

157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

220+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs

158− rename' (Definition p body mtipe) =

221+ rename' (Valid.Definition p body mtipe) =

222+ Canonical.Definition

159− Definition <$> format (renamePattern env' p)

223+ <$> format (pattern env' p)

160− <*> rename env' body

224+ <*> expression env' body

161− <*> T.traverse (renameType' env') mtipe

225+ <*> T.traverse (tipe' env') mtipe

162

226

163− -- TODO: Raw -> Canonical

164− Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)

227+ Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)

165

228

166− Data name es -> Data name <$> mapM rnm es

229+ Data name es -> Data name <$> mapM go es

167

230

168− ExplicitList es -> ExplicitList <$> mapM rnm es

231+ ExplicitList es -> ExplicitList <$> mapM go es

169

232

170− Case e cases -> Case <$> rnm e <*> mapM branch cases

233+ Case e cases -> Case <$> go e <*> mapM branch cases

171 where

234 where

172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)

235+ branch (p,b) = (,) <$> format (pattern env p)

173− <*> rename (extend env pattern) b

236+ <*> expression (update p env) b

174−

237+

238+ Markdown uid md es ->

239+ do Env.uses "Text"

175− Markdown uid md es -> Markdown uid md <$> mapM rnm es

240+ Markdown uid md <$> mapM go es

176−

241+

177− PortIn name st -> PortIn name <$> renameType' env st

242+ PortIn name st -> PortIn name <$> tipe' env st

178−

243+

179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

244+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal

180−

245+

181− GLShader _ _ _ -> return expr

246+ GLShader uid src tipe -> return (GLShader uid src tipe)

182−

247+

183−renamePattern :: Env -> P.Pattern -> Either String P.Pattern

248+pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern

184−renamePattern env pattern =

249+pattern env ptrn =

185− case pattern of

250+ case ptrn of

186− P.Var _ -> return pattern

251+ P.Var x -> return $ P.Var x

187− P.Literal _ -> return pattern

252+ P.Literal lit -> return $ P.Literal lit

188− P.Record _ -> return pattern

253+ P.Record fs -> return $ P.Record fs

189− P.Anything -> return pattern

254+ P.Anything -> return P.Anything

190− P.Alias x p -> P.Alias x <$> renamePattern env p

255+ P.Alias x p -> P.Alias x <$> pattern env p

191− P.Data name ps -> P.Data <$> replace "pattern" env name

256+ P.Data (Var.Raw name) ps ->

257+ P.Data <$> Canonicalize.pvar env name

192− <*> mapM (renamePattern env) ps

258+ <*> mapM (pattern env) ps

compiler/Transform/Canonicalize/Environment.hsnew file+84

@@ -0,0 +1,84 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Environment where

3+

4+import Control.Arrow (second)

5+import qualified Control.Monad.Error as Error

6+import qualified Control.Monad.State as State

7+import qualified Data.Map as Map

8+import qualified Data.Set as Set

9+

10+import AST.Expression.General (saveEnvName)

11+import qualified AST.Pattern as P

12+import qualified AST.Type as Type

13+import qualified AST.Variable as Var

14+

15+import Text.PrettyPrint (Doc)

16+

17+type Dict a = Map.Map String [a]

18+

19+dict :: [(String,a)] -> Dict a

20+dict pairs = Map.fromList $ map (second (:[])) pairs

21+

22+insert :: String -> a -> Dict a -> Dict a

23+insert key value = Map.insertWith (++) key [value]

24+

25+type Canonicalizer err a = Error.ErrorT err (State.State (Set.Set String)) a

26+

27+uses :: (Error.Error e) => String -> Canonicalizer e ()

28+uses home =

29+ Error.lift (State.modify (Set.insert home))

30+

31+using :: Var.Canonical -> Canonicalizer String Var.Canonical

32+using var@(Var.Canonical home _) =

33+ do case home of

34+ Var.BuiltIn -> return ()

35+ Var.Module path -> uses path

36+ Var.Local -> return ()

37+ return var

38+

39+onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a

40+onError handler canonicalizer =

41+ do usedModules <- Error.lift State.get

42+ let (result, usedModules') =

43+ State.runState (Error.runErrorT canonicalizer) usedModules

44+ Error.lift (State.put usedModules')

45+ case result of

46+ Left err -> Error.throwError [handler err]

47+ Right x -> return x

48+

49+data Environment = Env

50+ { _home :: String

51+ , _values :: Dict Var.Canonical

52+ , _adts :: Dict Var.Canonical

53+ , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType)

54+ , _patterns :: Dict Var.Canonical

55+ }

56+

57+builtIns :: String -> Environment

58+builtIns home =

59+ Env { _home = home

60+ , _values = builtIn (tuples ++ [saveEnvName])

61+ , _adts = builtIn (tuples ++ ["_List","Int","Float","Char","Bool","String"])

62+ , _aliases = dict []

63+ , _patterns = builtIn (tuples ++ ["::","[]"])

64+ }

65+ where

66+ builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs

67+ tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

68+

69+update :: P.Pattern var -> Environment -> Environment

70+update ptrn env =

71+ env { _values = foldr put (_values env) (P.boundVarList ptrn) }

72+ where

73+ put x = Map.insert x [Var.local x]

74+

75+merge :: Environment -> Environment -> Environment

76+merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)

77+ | n1 /= n2 = error "trying to merge incompatable environments"

78+ | otherwise =

79+ Env { _home = n1

80+ , _values = Map.unionWith (++) v1 v2

81+ , _adts = Map.unionWith (++) t1 t2

82+ , _aliases = Map.unionWith (++) a1 a2

83+ , _patterns = Map.unionWith (++) p1 p2

84+ }

compiler/Transform/Canonicalize/Setup.hsnew file+220

@@ -0,0 +1,220 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Setup (environment) where

3+

4+import Control.Arrow (first)

5+import Control.Monad (foldM)

6+import Control.Monad.Error (throwError)

7+import qualified Data.Graph as Graph

8+import qualified Data.List as List

9+import qualified Data.Map as Map

10+

11+import qualified AST.Expression.Valid as Valid

12+

13+import AST.Module (Interface(iAdts, iTypes, iAliases))

14+import qualified AST.Module as Module

15+import qualified AST.Type as Type

16+import qualified AST.Variable as Var

17+import qualified AST.Declaration as D

18+import AST.PrettyPrint (pretty, eightyCharLines)

19+import qualified AST.Pattern as P

20+import Text.PrettyPrint as P

21+

22+import Transform.Canonicalize.Environment as Env

23+import qualified Transform.Canonicalize.Type as Canonicalize

24+

25+environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment

26+environment interfaces modul@(Module.Module _ _ _ imports decls) =

27+ do () <- allImportsAvailable

28+ let moduleName = Module.getName modul

29+ nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports

30+ let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls

31+ addTypeAliases moduleName aliases env

32+ where

33+ allImportsAvailable :: Canonicalizer [Doc] ()

34+ allImportsAvailable =

35+ case filter (not . found) modules of

36+ [] -> return ()

37+ missings -> throwError [ P.text (missingModuleError missings) ]

38+ where

39+ modules = map fst imports

40+

41+ found m = Map.member m interfaces || List.isPrefixOf "Native." m

42+

43+ missingModuleError missings =

44+ concat [ "The following imports were not found: "

45+ , List.intercalate ", " missings

46+ , "\n You may need to compile with the --make "

47+ , "flag to detect modules you have written." ]

48+

49+addImports :: String -> Module.Interfaces -> Environment -> (String, Module.ImportMethod)

50+ -> Canonicalizer [Doc] Environment

51+addImports moduleName interfaces environ (name,method)

52+ | List.isPrefixOf "Native." name = return environ

53+ | otherwise =

54+ case method of

55+ Module.As name' ->

56+ return (updateEnviron (name' ++ "."))

57+

58+ Module.Open (Var.Listing vs open)

59+ | open -> return (updateEnviron "")

60+ | otherwise -> foldM (addValue name interface) environ vs

61+ where

62+ interface = (Map.!) interfaces name

63+

64+ updateEnviron prefix =

65+ let dict' = dict . map (first (prefix++)) in

66+ merge environ $

67+ Env { _home = moduleName

68+ , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors

69+ , _adts = dict' $ map pair (Map.keys (iAdts interface))

70+ , _aliases = dict' $ map alias (Map.toList (iAliases interface))

71+ , _patterns = dict' $ ctors

72+ }

73+

74+ canonical :: String -> Var.Canonical

75+ canonical = Var.Canonical (Var.Module name)

76+

77+ pair :: String -> (String, Var.Canonical)

78+ pair key = (key, canonical key)

79+

80+ alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe))

81+

82+ ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface))

83+

84+addValue :: String -> Module.Interface -> Environment -> Var.Value

85+ -> Canonicalizer [Doc] Environment

86+addValue name interface env value =

87+ let insert' x = insert x (Var.Canonical (Var.Module name) x)

88+ msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++

89+ "'.\n It is not exported by module " ++ name ++ "."

90+ notFound x = throwError [ P.text (msg x) ]

91+ in

92+ case value of

93+ Var.Value x

94+ | Map.notMember x (iTypes interface) -> notFound x

95+ | otherwise ->

96+ return $ env { _values = insert' x (_values env) }

97+

98+ Var.Alias x ->

99+ case Map.lookup x (iAliases interface) of

100+ Just (tvars, t) ->

101+ let v = (Var.Canonical (Var.Module name) x, tvars, t) in

102+ return $ env { _aliases = insert x v (_aliases env) }

103+ Nothing ->

104+ case Map.lookup x (iAdts interface) of

105+ Nothing -> notFound x

106+ Just (_,_) ->

107+ return $ env { _adts = insert' x (_adts env) }

108+

109+ Var.ADT x (Var.Listing xs open) ->

110+ case Map.lookup x (iAdts interface) of

111+ Nothing -> notFound x

112+ Just (_tvars, ctors) ->

113+ do ctors' <- filterNames (map fst ctors)

114+ return $ env { _adts = insert' x (_adts env)

115+ , _values = foldr insert' (_values env) ctors'

116+ , _patterns = foldr insert' (_patterns env) ctors'

117+ }

118+ where

119+ filterNames names

120+ | open = return names

121+ | otherwise =

122+ case filter (`notElem` names) xs of

123+ [] -> return names

124+ c:_ -> notFound c

125+

126+type Node = ((String, [String], Type.RawType), String, [String])

127+

128+node :: String -> [String] -> Type.RawType -> Node

129+node name tvars alias = ((name, tvars, alias), name, edges alias)

130+ where

131+ edges tipe =

132+ case tipe of

133+ Type.Lambda t1 t2 -> edges t1 ++ edges t2

134+ Type.Var _ -> []

135+ Type.Type (Var.Raw x) -> [x]

136+ Type.App t ts -> edges t ++ concatMap edges ts

137+ Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs

138+ Type.Aliased _ t -> edges t

139+

140+addTypeAliases :: String -> [Node] -> Environment -> Canonicalizer [Doc] Environment

141+addTypeAliases moduleName nodes environ =

142+ foldM addTypeAlias environ (Graph.stronglyConnComp nodes)

143+ where

144+ addTypeAlias :: Environment -> Graph.SCC (String, [String], Type.RawType)

145+ -> Canonicalizer [Doc] Environment

146+ addTypeAlias env scc =

147+ case Graph.flattenSCC scc of

148+ [(name, tvars, alias)] ->

149+ do alias' <- Env.onError throw (Canonicalize.tipe env alias)

150+ let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')

151+ return $ env { _aliases = insert name value (_aliases env) }

152+ where

153+ throw err =

154+ let msg = "Problem with type alias '" ++ name ++ "':"

155+ in P.vcat [ P.text msg, P.text err ]

156+

157+ aliases ->

158+ throwError [ P.vcat [ P.text (eightyCharLines 0 msg1)

159+ , indented (map typeAlias aliases)

160+ , P.text (eightyCharLines 0 msg2)

161+ , indented (map datatype aliases)

162+ , P.text (eightyCharLines 0 msg3)

163+ ]

164+ ]

165+

166+ typeAlias (n,ts,t) = D.TypeAlias n ts t

167+ datatype (n,ts,t) = D.Datatype n ts [(n,[t])]

168+

169+ indented :: [D.ValidDecl] -> Doc

170+ indented decls = P.vcat (map prty decls) <> P.text "\n"

171+ where

172+ prty decl = P.text "\n " <> pretty decl

173+

174+ msg1 = "The following type aliases are mutually recursive, forming an \

175+ \infinite type. When you expand them, they just keep getting bigger:"

176+ msg2 = "Instead, you can try something like this:"

177+ msg3 = "It looks very similar, but an algebraic data type (ADT) \

178+ \actually creates a new type. Unlike with a type alias, this \

179+ \freshly created type is meaningful on its own, so an ADT \

180+ \does not need to be expanded."

181+

182+

183+-- When canonicalizing, all _values should be Local, but all _adts and _patterns

184+-- should be fully namespaced. With _adts, they may appear in types that can

185+-- escape the module.

186+addDecl :: String -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment)

187+addDecl moduleName info@(nodes,env) decl =

188+ let namespacedVar = Var.Canonical (Var.Module moduleName)

189+ addLocal x e = insert x (Var.local x) e

190+ addNamespaced x e = insert x (namespacedVar x) e

191+ in

192+ case decl of

193+ D.Definition (Valid.Definition pattern _ _) ->

194+ (,) nodes $ env

195+ { _values = foldr addLocal (_values env) (P.boundVarList pattern) }

196+

197+ D.Datatype name _ ctors ->

198+ (,) nodes $ env

199+ { _values = addCtors addLocal (_values env)

200+ , _adts = addNamespaced name (_adts env)

201+ , _patterns = addCtors addNamespaced (_patterns env)

202+ }

203+ where

204+ addCtors how e = foldr how e (map fst ctors)

205+

206+ D.TypeAlias name tvars alias ->

207+ (,) (node name tvars alias : nodes) $ env

208+ { _values = case alias of

209+ Type.Record _ _ -> addLocal name (_values env)

210+ _ -> _values env

211+ }

212+

213+ D.Port port ->

214+ let portName = case port of

215+ D.Out name _ _ -> name

216+ D.In name _ -> name

217+ in

218+ (,) nodes $ env { _values = addLocal portName (_values env) }

219+

220+ D.Fixity _ _ _ -> info

compiler/Transform/Canonicalize/Type.hsnew file+71

@@ -0,0 +1,71 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Type (tipe) where

3+

4+import Control.Arrow (second)

5+import Control.Applicative ((<$>),(<*>))

6+import Control.Monad.Error

7+import qualified Data.Map as Map

8+import Data.Traversable (traverse)

9+

10+import qualified AST.Type as T

11+import qualified AST.Variable as Var

12+

13+import Transform.Canonicalize.Environment

14+import qualified Transform.Canonicalize.Variable as Canonicalize

15+

16+tipe :: Environment -> T.RawType -> Canonicalizer String T.CanonicalType

17+tipe env typ =

18+ let go = tipe env in

19+ case typ of

20+ T.Var x -> return (T.Var x)

21+ T.Type _ -> canonicalizeApp env typ []

22+ T.App t ts -> canonicalizeApp env t ts

23+

24+ T.Lambda a b -> T.Lambda <$> go a <*> go b

25+ T.Aliased name t -> T.Aliased name <$> go t

26+

27+ T.Record fields ext ->

28+ let go' (f,t) = (,) f <$> go t

29+ in T.Record <$> mapM go' fields <*> traverse go ext

30+

31+canonicalizeApp :: Environment -> T.RawType -> [T.RawType]

32+ -> Canonicalizer String T.CanonicalType

33+canonicalizeApp env f args =

34+ case f of

35+ T.Type (Var.Raw rawName) ->

36+ do answer <- Canonicalize.tvar env rawName

37+ case answer of

38+ Right alias -> canonicalizeAlias env alias args

39+ Left name -> case args of

40+ [] -> return (T.Type name)

41+ _:_ -> T.App (T.Type name) <$> mapM (tipe env) args

42+

43+ _ -> T.App <$> tipe env f <*> mapM (tipe env) args

44+

45+canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)

46+ -> [T.RawType]

47+ -> Canonicalizer String T.CanonicalType

48+canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

49+ do when (tipesLen /= tvarsLen) (throwError msg)

50+ tipes' <- mapM (tipe env) tipes

51+ let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe

52+ return $ T.Aliased name tipe'

53+ where

54+ tipesLen = length tipes

55+ tvarsLen = length tvars

56+

57+ msg :: String

58+ msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

59+ " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

60+ " but was given " ++ show tipesLen

61+

62+ replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

63+ replace typeTable t =

64+ let go = replace typeTable in

65+ case t of

66+ T.Lambda a b -> T.Lambda (go a) (go b)

67+ T.Var x -> Map.findWithDefault t x typeTable

68+ T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)

69+ T.Aliased original t' -> T.Aliased original (go t')

70+ T.Type _ -> t

71+ T.App f args -> T.App (go f) (map go args)

compiler/Transform/Canonicalize/Variable.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Canonicalize.Variable where

3+

4+import Control.Monad.Error

5+import qualified Data.List as List

6+import qualified Data.Map as Map

7+import Data.Maybe (fromMaybe)

8+

9+import AST.Helpers as Help

10+import qualified AST.Type as Type

11+import qualified AST.Variable as Var

12+import Transform.Canonicalize.Environment as Env

13+

14+variable :: Environment -> String -> Canonicalizer String Var.Canonical

15+variable env var =

16+ case modul of

17+ Just ms@(m:_)

18+ | m == "Native" -> Env.using (Var.Canonical home name)

19+ where

20+ home = Var.Module (List.intercalate "." ms)

21+

22+ _ -> case Map.lookup var (_values env) of

23+ Just [v] -> Env.using v

24+ Just vs -> preferLocals env "variable" vs var

25+ Nothing -> notFound "variable" (Map.keys (_values env)) var

26+ where

27+ (modul, name) = case Help.splitDots var of

28+ [x] -> (Nothing, x)

29+ xs -> (Just (init xs), last xs)

30+

31+tvar :: Environment -> String

32+ -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))

33+tvar env var =

34+ case adts ++ aliases of

35+ [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var

36+ [v] -> found extract v

37+ vs -> preferLocals' env extract "type" vs var

38+ where

39+ adts = map Left . fromMaybe [] $ Map.lookup var (_adts env)

40+ aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env)

41+

42+ extract value =

43+ case value of

44+ Left v -> v

45+ Right (v,_,_) -> v

46+

47+pvar :: Environment -> String -> Canonicalizer String Var.Canonical

48+pvar env var =

49+ case Map.lookup var (_patterns env) of

50+ Just [v] -> Env.using v

51+ Just vs -> preferLocals env "pattern" vs var

52+ Nothing -> notFound "pattern" (Map.keys (_patterns env)) var

53+

54+found :: (a -> Var.Canonical) -> a -> Canonicalizer String a

55+found extract v = do

56+ _ <- Env.using (extract v)

57+ return v

58+

59+notFound :: String -> [String] -> String -> Canonicalizer String a

60+notFound kind possibilities var =

61+ throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg

62+ where

63+ matches = filter (List.isInfixOf var) possibilities

64+ msg = if null matches then "" else

65+ "\nClose matches include: " ++ List.intercalate ", " matches

66+

67+preferLocals :: Environment -> String -> [Var.Canonical] -> String

68+ -> Canonicalizer String Var.Canonical

69+preferLocals env = preferLocals' env id

70+

71+preferLocals' :: Environment -> (a -> Var.Canonical) -> String -> [a] -> String

72+ -> Canonicalizer String a

73+preferLocals' env extract kind possibilities var =

74+ case filter (isLocal . extract) possibilities of

75+ [] -> ambiguous possibilities

76+ [v] -> found extract v

77+ locals -> ambiguous locals

78+ where

79+ isLocal :: Var.Canonical -> Bool

80+ isLocal (Var.Canonical home _) =

81+ case home of

82+ Var.Local -> True

83+ Var.BuiltIn -> False

84+ Var.Module name -> name == Env._home env

85+

86+ ambiguous possibleVars =

87+ throwError msg

88+ where

89+ vars = map (Var.toString . extract) possibleVars

90+ msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++

91+ " Disambiguate between: " ++ List.intercalate ", " vars

92+

compiler/Transform/Check.hs+24−18

@@ -6,17 +6,18 @@ import qualified Data.List as List

6import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

8

9−import qualified SourceSyntax.Expression as E

9+import qualified AST.Expression.Valid as Valid

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

11−import qualified SourceSyntax.Pattern as Pattern

11+import qualified AST.Pattern as Pattern

12−import qualified SourceSyntax.Type as T

12+import qualified AST.Type as T

13+import qualified AST.Variable as Var

13import qualified Transform.Expression as Expr

14import qualified Transform.Expression as Expr

14

15

15−import SourceSyntax.PrettyPrint

16+import AST.PrettyPrint

16import Text.PrettyPrint as P

17import Text.PrettyPrint as P

17

18

19

19−mistakes :: [D.Declaration] -> [Doc]

20+mistakes :: [D.ValidDecl] -> [Doc]

20mistakes decls =

21mistakes decls =

21 concat [ infiniteTypeAliases decls

22 concat [ infiniteTypeAliases decls

22 , illFormedTypes decls

23 , illFormedTypes decls

@@ -30,7 +31,7 @@ dupErr :: String -> String -> String

30dupErr err x =

31dupErr err x =

31 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

32 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

32

33

33−duplicates :: [D.Declaration] -> [String]

34+duplicates :: [D.ValidDecl] -> [String]

34duplicates decls =

35duplicates decls =

35 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

36 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

36 case mapM exprDups (portExprs ++ defExprs) of

37 case mapM exprDups (portExprs ++ defExprs) of

@@ -41,7 +42,7 @@ duplicates decls =

41 msg = dupErr "definition of"

42 msg = dupErr "definition of"

42

43

43 (defPatterns, defExprs) =

44 (defPatterns, defExprs) =

44− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45+ unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

45

46

46 (portNames, portExprs) =

47 (portNames, portExprs) =

47 Arrow.second concat $ unzip $

48 Arrow.second concat $ unzip $

@@ -50,17 +51,17 @@ duplicates decls =

50 D.Out name expr _ -> (name, [expr])

51 D.Out name expr _ -> (name, [expr])

51 D.In name _ -> (name, [])

52 D.In name _ -> (name, [])

52

53

53− exprDups :: E.Expr -> Either String E.Expr

54+ exprDups :: Valid.Expr -> Either String Valid.Expr

54 exprDups expr = Expr.crawlLet defsDups expr

55 exprDups expr = Expr.crawlLet defsDups expr

55

56

56− defsDups :: [E.Def] -> Either String [E.Def]

57+ defsDups :: [Valid.Def] -> Either String [Valid.Def]

57 defsDups defs =

58 defsDups defs =

58− let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in

59+ let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

59 case dups $ concatMap varsIn defs of

60 case dups $ concatMap varsIn defs of

60 [] -> Right defs

61 [] -> Right defs

61 name:_ -> Left name

62 name:_ -> Left name

62

63

63−duplicateConstructors :: [D.Declaration] -> [String]

64+duplicateConstructors :: [D.ValidDecl] -> [String]

64duplicateConstructors decls =

65duplicateConstructors decls =

65 map (dupErr "definition of type constructor") (dups typeCtors) ++

66 map (dupErr "definition of type constructor") (dups typeCtors) ++

66 map (dupErr "definition of data constructor") (dups dataCtors)

67 map (dupErr "definition of data constructor") (dups dataCtors)

@@ -68,7 +69,7 @@ duplicateConstructors decls =

68 typeCtors = [ name | D.Datatype name _ _ <- decls ]

69 typeCtors = [ name | D.Datatype name _ _ <- decls ]

69 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

70 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

70

71

71−illFormedTypes :: [D.Declaration] -> [Doc]

72+illFormedTypes :: [D.ValidDecl] -> [Doc]

72illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

73illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

73 where

74 where

74 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

75 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

@@ -78,9 +79,11 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

78 case tipe of

79 case tipe of

79 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

80 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

80 T.Var x -> Set.singleton x

81 T.Var x -> Set.singleton x

82+ T.Type _ -> Set.empty

81− T.Data _ ts -> Set.unions (map freeVars ts)

83+ T.App t ts -> Set.unions (map freeVars (t:ts))

82 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

84 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

83− where ext' = maybe Set.empty Set.singleton ext

85+ where ext' = maybe Set.empty freeVars ext

86+ T.Aliased _ t -> freeVars t

84

87

85 undeclared tvars tipes = Set.difference used declared

88 undeclared tvars tipes = Set.difference used declared

86 where

89 where

@@ -113,20 +116,23 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

113 quote tvar = "'" ++ tvar ++ "'"

116 quote tvar = "'" ++ tvar ++ "'"

114

117

115

118

116−infiniteTypeAliases :: [D.Declaration] -> [Doc]

119+infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

117infiniteTypeAliases decls =

120infiniteTypeAliases decls =

118 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

121 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

119 , infiniteType name tipe ]

122 , infiniteType name tipe ]

120 where

123 where

124+ infiniteType :: String -> T.Type Var.Raw -> Bool

121 infiniteType name tipe =

125 infiniteType name tipe =

122 let infinite = infiniteType name in

126 let infinite = infiniteType name in

123 case tipe of

127 case tipe of

124 T.Lambda a b -> infinite a || infinite b

128 T.Lambda a b -> infinite a || infinite b

125 T.Var _ -> False

129 T.Var _ -> False

130+ T.Type (Var.Raw name') -> name == name'

126− T.Data name' ts -> name == name' || any infinite ts

131+ T.App t ts -> any infinite (t:ts)

127 T.Record fields _ -> any (infinite . snd) fields

132 T.Record fields _ -> any (infinite . snd) fields

133+ T.Aliased _ t -> infinite t

128

134

129− indented :: D.Declaration -> Doc

135+ indented :: D.ValidDecl -> Doc

130 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

136 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

131

137

132 report name args tipe =

138 report name args tipe =

compiler/Transform/Declaration.hs+89−24

@@ -1,16 +1,23 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration where

2+module Transform.Declaration (combineAnnotations, toExpr) where

3

4import Control.Applicative ((<$>))

5+

5−import qualified SourceSyntax.Pattern as P

6+import qualified AST.Annotation as A

6−import SourceSyntax.Expression as E

7−import SourceSyntax.Declaration as D

7+import qualified AST.Declaration as D

8+import qualified AST.Expression.General as E

9+import qualified AST.Expression.Source as Source

10+import qualified AST.Expression.Valid as Valid

11+import qualified AST.Expression.Canonical as Canonical

12+import qualified AST.Pattern as P

13+import qualified AST.Type as T

14+import qualified AST.Variable as Var

8

15

9import qualified Transform.Expression as Expr

16import qualified Transform.Expression as Expr

10import qualified Transform.Definition as Def

17import qualified Transform.Definition as Def

11

18

12

19

13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

20+combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

14combineAnnotations = go

21combineAnnotations = go

15 where

22 where

16 msg x = "Syntax Error: The type annotation for '" ++ x ++

23 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -23,41 +30,99 @@ combineAnnotations = go

23 -- simple cases, pass them through with no changes

30 -- simple cases, pass them through with no changes

24 [] -> return []

31 [] -> return []

25

32

26− Datatype name tvars ctors : rest ->

33+ D.Datatype name tvars ctors : rest ->

27− (:) (Datatype name tvars ctors) <$> go rest

34+ (:) (D.Datatype name tvars ctors) <$> go rest

28

35

29− TypeAlias name tvars alias : rest ->

36+ D.TypeAlias name tvars alias : rest ->

30− (:) (TypeAlias name tvars alias) <$> go rest

37+ (:) (D.TypeAlias name tvars alias) <$> go rest

31

38

32− Fixity assoc prec op : rest ->

39+ D.Fixity assoc prec op : rest ->

33− (:) (Fixity assoc prec op) <$> go rest

40+ (:) (D.Fixity assoc prec op) <$> go rest

34

41

35 -- combine definitions

42 -- combine definitions

36 D.Definition def : defRest ->

43 D.Definition def : defRest ->

37 case def of

44 case def of

38− Def pat expr ->

45+ Source.Definition pat expr ->

39 do expr' <- exprCombineAnnotations expr

46 do expr' <- exprCombineAnnotations expr

40− let def' = E.Definition pat expr' Nothing

47+ let def' = Valid.Definition pat expr' Nothing

41 (:) (D.Definition def') <$> go defRest

48 (:) (D.Definition def') <$> go defRest

42

49

43− TypeAnnotation name tipe ->

50+ Source.TypeAnnotation name tipe ->

44 case defRest of

51 case defRest of

45− D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->

52+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest

53+ | name == name' ->

46− do expr' <- exprCombineAnnotations expr

54+ do expr' <- exprCombineAnnotations expr

47− let def' = E.Definition pat expr' (Just tipe)

55+ let def' = Valid.Definition pat expr' (Just tipe)

48− (:) (D.Definition def') <$> go rest

56+ (:) (D.Definition def') <$> go rest

49

57

50 _ -> Left (msg name)

58 _ -> Left (msg name)

51

59

52 -- combine ports

60 -- combine ports

53− Port port : portRest ->

61+ D.Port port : portRest ->

54 case port of

62 case port of

55− PPDef name _ -> Left (msg name)

63+ D.PPDef name _ -> Left (msg name)

56− PPAnnotation name tipe ->

64+ D.PPAnnotation name tipe ->

57 case portRest of

65 case portRest of

58− Port (PPDef name' expr) : rest | name == name' ->

66+ D.Port (D.PPDef name' expr) : rest | name == name' ->

59 do expr' <- exprCombineAnnotations expr

67 do expr' <- exprCombineAnnotations expr

60− (:) (Port (Out name expr' tipe)) <$> go rest

68+ (:) (D.Port (D.Out name expr' tipe)) <$> go rest

69+

70+ _ -> (:) (D.Port (D.In name tipe)) <$> go portRest

71+

72+

73+toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]

74+toExpr moduleName = concatMap (toDefs moduleName)

75+

76+toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]

77+toDefs moduleName decl =

78+ let typeVar = Var.Canonical (Var.Module moduleName) in

79+ case decl of

80+ D.Definition def -> [def]

81+

82+ D.Datatype name tvars constructors -> concatMap toDefs' constructors

83+ where

84+ toDefs' (ctor, tipes) =

85+ let vars = take (length tipes) arguments

86+ tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

87+ body = A.none . E.Data ctor $ map (A.none . E.localVar) vars

88+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

89+

90+ D.TypeAlias name _ tipe@(T.Record fields ext) ->

91+ [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

92+ where

93+ result = T.Aliased (typeVar name) tipe

94+

95+ args = map snd fields ++ maybe [] (:[]) ext

96+

97+ var = A.none . E.localVar

98+ vars = take (length args) arguments

99+

100+ efields = zip (map fst fields) (map var vars)

101+ record = case ext of

102+ Nothing -> A.none $ E.Record efields

103+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

104+

105+ -- Type aliases must be added to an extended equality dictionary,

106+ -- but they do not require any basic constraints.

107+ D.TypeAlias _ _ _ -> []

108+

109+ D.Port port ->

110+ case port of

111+ D.Out name expr@(A.A s _) tipe ->

112+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

113+ D.In name tipe ->

114+ [ definition name (A.none $ E.PortIn name tipe) tipe ]

115+

116+ -- no constraints are needed for fixity declarations

117+ D.Fixity _ _ _ -> []

118+

119+

120+arguments :: [String]

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

61

122

62− _ -> (:) (Port (In name tipe)) <$> go portRest

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

124+buildFunction body@(A.A s _) vars =

125+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

63

126

127+definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def

128+definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)

compiler/Transform/Definition.hs+14−10

@@ -2,11 +2,12 @@

2module Transform.Definition where

3

4import Control.Applicative ((<$>))

5−import qualified SourceSyntax.Pattern as P

5+import qualified AST.Pattern as P

6−import SourceSyntax.Expression

6+import qualified AST.Expression.Source as Source

7+import qualified AST.Expression.Valid as Valid

7import qualified Transform.Expression as Expr

8import qualified Transform.Expression as Expr

8

9

9−combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

10combineAnnotations = go

11combineAnnotations = go

11 where

12 where

12 msg x = "Syntax Error: The type annotation for '" ++ x ++

13 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -16,16 +17,19 @@ combineAnnotations = go

16

17

17 go defs =

18 go defs =

18 case defs of

19 case defs of

19− TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->

20+ Source.TypeAnnotation name tipe : rest ->

21+ case rest of

22+ Source.Definition pat@(P.Var name') expr : rest'

23+ | name == name' ->

20− do expr' <- exprCombineAnnotations expr

24+ do expr' <- exprCombineAnnotations expr

21− let def = Definition pat expr' (Just tipe)

25+ let def = Valid.Definition pat expr' (Just tipe)

22− (:) def <$> go rest

26+ (:) def <$> go rest'

23

27

24− TypeAnnotation name _ : _ -> Left (msg name)

28+ _ -> Left (msg name)

25

29

26− Def pat expr : rest ->

30+ Source.Definition pat expr : rest ->

27 do expr' <- exprCombineAnnotations expr

31 do expr' <- exprCombineAnnotations expr

28− let def = Definition pat expr' Nothing

32+ let def = Valid.Definition pat expr' Nothing

29 (:) def <$> go rest

33 (:) def <$> go rest

30

34

31 [] -> return []

35 [] -> return []

compiler/Transform/Expression.hs+15−14

@@ -2,31 +2,32 @@

2module Transform.Expression (crawlLet, checkPorts) where

3

4import Control.Applicative ((<$>),(<*>))

5−import SourceSyntax.Annotation ( Annotated(A) )

5+import AST.Annotation ( Annotated(A) )

6−import SourceSyntax.Expression

6+import AST.Expression.General

7−import SourceSyntax.Type (Type)

7+import qualified AST.Expression.Canonical as Canonical

8+import AST.Type (Type, CanonicalType)

8

9

9crawlLet :: ([def] -> Either a [def'])

10crawlLet :: ([def] -> Either a [def'])

10− -> GeneralExpr ann def var

11+ -> Expr ann def var

11− -> Either a (GeneralExpr ann def' var)

12+ -> Either a (Expr ann def' var)

12crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

13crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

13

14

14−checkPorts :: (String -> Type -> Either a ())

15+checkPorts :: (String -> CanonicalType -> Either a ())

15− -> (String -> Type -> Either a ())

16+ -> (String -> CanonicalType -> Either a ())

16− -> Expr

17+ -> Canonical.Expr

17− -> Either a Expr

18+ -> Either a Canonical.Expr

18checkPorts inCheck outCheck expr =

19checkPorts inCheck outCheck expr =

19 crawl inCheck outCheck (mapM checkDef) expr

20 crawl inCheck outCheck (mapM checkDef) expr

20 where

21 where

21− checkDef def@(Definition _ body _) =

22+ checkDef def@(Canonical.Definition _ body _) =

22 do _ <- checkPorts inCheck outCheck body

23 do _ <- checkPorts inCheck outCheck body

23 return def

24 return def

24

25

25−crawl :: (String -> Type -> Either a ())

26+crawl :: (String -> Type var -> Either a ())

26− -> (String -> Type -> Either a ())

27+ -> (String -> Type var -> Either a ())

27 -> ([def] -> Either a [def'])

28 -> ([def] -> Either a [def'])

28− -> GeneralExpr ann def var

29+ -> Expr ann def var

29− -> Either a (GeneralExpr ann def' var)

30+ -> Either a (Expr ann def' var)

30crawl portInCheck portOutCheck defsTransform = go

31crawl portInCheck portOutCheck defsTransform = go

31 where

32 where

32 go (A srcSpan expr) =

33 go (A srcSpan expr) =

compiler/Transform/SafeNames.hsdeleted−78

@@ -1,78 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.SafeNames (metadataModule) where

3−

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

5−import qualified Data.List as List

6−import qualified Data.Set as Set

7−

8−import qualified Parse.Helpers as PHelp

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import qualified SourceSyntax.Helpers as SHelp

12−import SourceSyntax.Module

13−import qualified SourceSyntax.Pattern as P

14−import qualified SourceSyntax.Variable as Variable

15−

16−var :: String -> String

17−var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots

18− where

19− deprime = map (\c -> if c == '\'' then '$' else c)

20− dereserve x = case Set.member x PHelp.jsReserveds of

21− False -> x

22− True -> "$" ++ x

23−

24−pattern :: P.Pattern -> P.Pattern

25−pattern pat =

26− case pat of

27− P.Var x -> P.Var (var x)

28− P.Literal _ -> pat

29− P.Record fs -> P.Record (map var fs)

30− P.Anything -> pat

31− P.Alias x p -> P.Alias (var x) (pattern p)

32− P.Data name ps -> P.Data name (map pattern ps)

33−

34−-- TODO: should be "normal expression" -> "expression for JS generation"

35−expression :: Expr -> Expr

36−expression (A ann expr) =

37− let f = expression in

38− A ann $

39− case expr of

40− Literal _ -> expr

41− Var (Variable.Raw x) -> rawVar (var x)

42− Range e1 e2 -> Range (f e1) (f e2)

43− ExplicitList es -> ExplicitList (map f es)

44− Binop op e1 e2 -> Binop op (f e1) (f e2)

45− Lambda p e -> Lambda (pattern p) (f e)

46− App e1 e2 -> App (f e1) (f e2)

47− MultiIf ps -> MultiIf (map (f *** f) ps)

48− Let defs body -> Let (map definition defs) (f body)

49− Case e cases -> Case (f e) $ map (pattern *** f) cases

50− Data name es -> Data name (map f es)

51− Access e x -> Access (f e) (var x)

52− Remove e x -> Remove (f e) (var x)

53− Insert e x v -> Insert (f e) (var x) (f v)

54− Modify r fs -> Modify (f r) (map (var *** f) fs)

55− Record fs -> Record (map (var *** f) fs)

56− Markdown uid md es -> Markdown uid md (map f es)

57− GLShader _ _ _ -> expr

58− PortIn name st -> PortIn name st

59− PortOut name st signal -> PortOut name st (f signal)

60−

61−definition :: Def -> Def

62−definition (Definition p e t) =

63− Definition (pattern p) (expression e) t

64−

65−metadataModule :: MetadataModule -> MetadataModule

66−metadataModule modul =

67− modul

68− { names = map var (names modul)

69− , exports = map var (exports modul)

70− , imports = map (first var) (imports modul)

71− , program = expression (program modul)

72− , aliases =

73− let makeSafe (name,tvars,tipe) = (var name, tvars, tipe)

74− in map makeSafe (aliases modul)

75− , datatypes =

76− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

77− in map makeSafe (datatypes modul)

78− }

compiler/Transform/SortDefinitions.hs+37−21

@@ -7,42 +7,57 @@ import qualified Data.Graph as Graph

7import qualified Data.Map as Map

8import qualified Data.Maybe as Maybe

9import qualified Data.Set as Set

10−import SourceSyntax.Annotation

11−import SourceSyntax.Expression

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Variable as V

14

10

11+import AST.Annotation

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

13+import qualified AST.Expression.Canonical as Canonical

14+import qualified AST.Pattern as P

15+import qualified AST.Variable as V

16+

15−ctors :: P.Pattern -> [String]

17+ctors :: P.CanonicalPattern -> [String]

16ctors pattern =

18ctors pattern =

17 case pattern of

19 case pattern of

18 P.Var _ -> []

20 P.Var _ -> []

19 P.Alias _ p -> ctors p

21 P.Alias _ p -> ctors p

20− P.Data ctor ps -> ctor : concatMap ctors ps

21 P.Record _ -> []

22 P.Record _ -> []

22 P.Anything -> []

23 P.Anything -> []

23 P.Literal _ -> []

24 P.Literal _ -> []

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

26+ case home of

27+ V.Local -> name : rest

28+ V.BuiltIn -> rest

29+ V.Module _ -> rest

30+ where

31+ rest = concatMap ctors ps

24

32

25free :: String -> State (Set.Set String) ()

33free :: String -> State (Set.Set String) ()

26free x = modify (Set.insert x)

34free x = modify (Set.insert x)

27

35

36+freeIfLocal :: V.Canonical -> State (Set.Set String) ()

37+freeIfLocal (V.Canonical home name) =

38+ do case home of

39+ V.Local -> free name

40+ V.BuiltIn -> return ()

41+ V.Module _ -> return ()

42+

28bound :: Set.Set String -> State (Set.Set String) ()

43bound :: Set.Set String -> State (Set.Set String) ()

29bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

44bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

30

45

31−sortDefs :: Expr -> Expr

46+sortDefs :: Canonical.Expr -> Canonical.Expr

32sortDefs expr = evalState (reorder expr) Set.empty

47sortDefs expr = evalState (reorder expr) Set.empty

33

48

34−reorder :: Expr -> State (Set.Set String) Expr

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

35reorder (A ann expr) =

50reorder (A ann expr) =

36 A ann <$>

51 A ann <$>

37 case expr of

52 case expr of

38 -- Be careful adding and restricting freeVars

53 -- Be careful adding and restricting freeVars

39− Var (V.Raw x) -> free x >> return expr

54+ Var var -> freeIfLocal var >> return expr

40

55

41 Lambda p e ->

56 Lambda p e ->

42 uncurry Lambda <$> bindingReorder (p,e)

57 uncurry Lambda <$> bindingReorder (p,e)

43

58

44 Binop op e1 e2 ->

59 Binop op e1 e2 ->

45− do free op

60+ do freeIfLocal op

46 Binop op <$> reorder e1 <*> reorder e2

61 Binop op <$> reorder e1 <*> reorder e2

47

62

48 Case e cases ->

63 Case e cases ->

@@ -102,7 +117,7 @@ reorder (A ann expr) =

102 let defss = map Graph.flattenSCC sccs

117 let defss = map Graph.flattenSCC sccs

103

118

104 -- remove let-bound variables from the context

119 -- remove let-bound variables from the context

105− forM_ defs $ \(Definition pattern _ _) -> do

120+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do

106 bound (P.boundVars pattern)

121 bound (P.boundVars pattern)

107 mapM free (ctors pattern)

122 mapM free (ctors pattern)

108

123

@@ -110,7 +125,8 @@ reorder (A ann expr) =

110

125

111 return let'

126 return let'

112

127

128+bindingReorder :: (P.CanonicalPattern, Canonical.Expr)

113−bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)

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

114bindingReorder (pattern,expr) =

130bindingReorder (pattern,expr) =

115 do expr' <- reorder expr

131 do expr' <- reorder expr

116 bound (P.boundVars pattern)

132 bound (P.boundVars pattern)

@@ -118,8 +134,8 @@ bindingReorder (pattern,expr) =

118 return (pattern, expr')

134 return (pattern, expr')

119

135

120

136

121−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

137+reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

122−reorderAndGetDependencies (Definition pattern expr mType) =

138+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

123 do globalFrees <- get

139 do globalFrees <- get

124 -- work in a fresh environment

140 -- work in a fresh environment

125 put Set.empty

141 put Set.empty

@@ -127,28 +143,28 @@ reorderAndGetDependencies (Definition pattern expr mType) =

127 localFrees <- get

143 localFrees <- get

128 -- merge with global frees

144 -- merge with global frees

129 modify (Set.union globalFrees)

145 modify (Set.union globalFrees)

130− return (Definition pattern expr' mType, Set.toList localFrees)

146+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

131

147

132

148

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

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

134−buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]

150+buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])]

135buildDefDict defs =

151buildDefDict defs =

136 do pdefsDeps <- mapM reorderAndGetDependencies defs

152 do pdefsDeps <- mapM reorderAndGetDependencies defs

137 return $ realDeps (addKey pdefsDeps)

153 return $ realDeps (addKey pdefsDeps)

138

154

139 where

155 where

140− addKey :: [(Def, [String])] -> [(Def, Int, [String])]

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

141 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

157 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

142

158

143− variableToKey :: (Def, Int, [String]) -> [(String, Int)]

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

144− variableToKey (Definition pattern _ _, key, _) =

160+ variableToKey (Canonical.Definition pattern _ _, key, _) =

145 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

161 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

146

162

147− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

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

148 variableToKeyMap pdefsDeps =

164 variableToKeyMap pdefsDeps =

149 Map.fromList (concatMap variableToKey pdefsDeps)

165 Map.fromList (concatMap variableToKey pdefsDeps)

150

166

151− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

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

152 realDeps pdefsDeps = map convert pdefsDeps

168 realDeps pdefsDeps = map convert pdefsDeps

153 where

169 where

154 varDict = variableToKeyMap pdefsDeps

170 varDict = variableToKeyMap pdefsDeps

compiler/Transform/Substitute.hs+14−8

@@ -4,12 +4,13 @@ module Transform.Substitute (subst) where

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

5import qualified Data.Set as Set

6

7−import SourceSyntax.Annotation

7+import AST.Annotation

8−import SourceSyntax.Expression

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

9+import qualified AST.Expression.Canonical as Canonical

9−import qualified SourceSyntax.Pattern as Pattern

10+import qualified AST.Pattern as Pattern

10−import qualified SourceSyntax.Variable as V

11+import qualified AST.Variable as V

11

12

12−subst :: String -> Expr' -> Expr' -> Expr'

13+subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

13subst old new expr =

14subst old new expr =

14 let f (A a e) = A a (subst old new e) in

15 let f (A a e) = A a (subst old new e) in

15 case expr of

16 case expr of

@@ -26,11 +27,16 @@ subst old new expr =

26 | anyShadow -> expr

27 | anyShadow -> expr

27 | otherwise -> Let (map substDef defs) (f body)

28 | otherwise -> Let (map substDef defs) (f body)

28 where

29 where

29− substDef (Definition p e t) = Definition p (f e) t

30+ substDef (Canonical.Definition p e t) = Canonical.Definition p (f e) t

30 anyShadow =

31 anyShadow =

31− any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

32+ any (Set.member old . Pattern.boundVars) [ p | Canonical.Definition p _ _ <- defs ]

33+

34+ Var (V.Canonical home x) ->

35+ case home of

36+ V.Module _ -> expr

37+ V.BuiltIn -> expr

38+ V.Local -> if x == old then new else expr

32

39

33− Var (V.Raw x) -> if x == old then new else expr

34 Case e cases -> Case (f e) $ map (second f) cases

40 Case e cases -> Case (f e) $ map (second f) cases

35 Data name es -> Data name (map f es)

41 Data name es -> Data name (map f es)

36 Access e x -> Access (f e) x

42 Access e x -> Access (f e) x

compiler/Type/Alias.hsdeleted−139

@@ -1,139 +0,0 @@

1−{-# OPTIONS_GHC -W #-}

2−module Type.Alias (realias, rules, canonicalRealias, Rules) where

3−

4−import Control.Applicative ((<$>),(<*>))

5−import Control.Monad

6−import Control.Arrow (second)

7−import Data.Map ((!))

8−import qualified Data.Map as Map

9−import qualified Data.List as List

10−import SourceSyntax.Type

11−import SourceSyntax.Module

12−

13−type Rules = ([Alias], Type -> Type)

14−

15−rules interfaces moduleAliases moduleImports =

16− (collect interfaces moduleAliases, localizer moduleImports)

17−

18−collect interfaces moduleAliases =

19− filter (not . isPrimitive) rawAliases

20− where

21− rawAliases =

22− moduleAliases ++ concatMap iAliases (Map.elems interfaces)

23−

24− isPrimitive (_,_,tipe) =

25− case tipe of

26− Data _ [] -> True

27− _ -> False

28−

29−localizer moduleImports = go

30− where

31− go tipe =

32− case tipe of

33− Var _ -> tipe

34− Lambda t1 t2 -> Lambda (go t1) (go t2)

35− Data name ts -> Data (localize name) (map go ts)

36− Record fs ext -> Record (map (second go) fs) ext

37−

38− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

39− Map.empty moduleImports

40−

41− separate name =

42− case List.elemIndices '.' name of

43− [] -> ("",name)

44− is -> let i = last is in

45− (take i name, drop (i+1) name)

46−

47− shortest = List.minimumBy (\a b -> compare (length a) (length b))

48−

49− localize name = shortest (name : concatMap (localize' value) methods)

50− where (modul, value) = separate name

51− methods = Map.findWithDefault [] modul byMethod

52−

53− localize' name method =

54− case method of

55− As modul -> [modul ++ "." ++ name]

56− Hiding xs | name `notElem` xs -> [name]

57− Importing xs | name `elem` xs -> [name]

58− _ -> []

59−

60−realias :: Rules -> Type -> Type

61−realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62−

63−-- Realias using canonical aliases, so results will have aliases

64−-- that are fully qualified and possible to compare.

65−canonicalRealias :: [Alias] -> Type -> Type

66−canonicalRealias aliases tipe =

67− case concatMap tryRealias aliases of

68− [] -> if tipe == tipe' then tipe else f tipe'

69− tipes -> f (bestType tipes)

70− where

71− tryRealias (name, args, aliasTipe) =

72− case diff aliasTipe tipe of

73− Nothing -> []

74− Just kvs ->

75− let holes = collectFields kvs

76− hasArgs = List.sort args == Map.keys holes

77− isConsistent = all allEqual (Map.elems holes)

78− in case hasArgs && isConsistent of

79− False -> []

80− True -> [Data name $ map (\arg -> head (holes ! arg)) args]

81−

82− f = canonicalRealias aliases

83− tipe' =

84− case tipe of

85− Var _ -> tipe

86− Lambda t1 t2 -> Lambda (f t1) (f t2)

87− Data name ts -> Data name (map f ts)

88− Record fs ext -> Record (map (second f) fs) ext

89−

90−allEqual [] = True

91−allEqual (x:xs) = all (==x) xs

92−

93−bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

94− where

95− pairs :: [(Type,Int)]

96− pairs = zip tipes (map numFields tipes)

97−

98− numFields :: Type -> Int

99− numFields tipe =

100− case tipe of

101− Lambda t1 t2 -> numFields t1 + numFields t2

102− Var _ -> 0

103− Data _ ts -> sum (map numFields ts)

104− Record fields _ -> length fields + sum (map (numFields . snd) fields)

105−

106−diff :: Type -> Type -> Maybe [(String,Type)]

107−diff general specific =

108− case (general, specific) of

109− (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2

110− (Var x, t) -> Just [(x,t)]

111− (Data gname gts, Data sname sts)

112− | gname == sname && length gts == length sts ->

113− concat <$> zipWithM diff gts sts

114− (Record [] Nothing, Record [] Nothing) -> Just []

115− (Record _ _, Record [] Nothing) -> Nothing

116− (Record [] Nothing, Record _ _) -> Nothing

117− (Record gfs gext, Record sfs sext) ->

118− let gfields = collectFields gfs

119− sfields = collectFields sfs

120−

121− overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

122− isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)

123− in

124− case isAligned of

125− False -> Nothing

126− True -> let remaining = Map.difference sfields gfields

127− sext' = case sext of

128− Just x | Map.null remaining -> Var x

129− _ -> Record (flattenFields remaining) sext

130− gext' = maybe (Record [] Nothing) Var gext

131− matchMap = Map.intersectionWith (zipWith diff) gfields sfields

132− in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))

133− (_,_) -> Nothing

134−

135−collectFields fields =

136− foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields

137−

138−flattenFields fields =

139− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)

compiler/Type/Constrain/Declaration.hsdeleted−62

@@ -1,62 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Type.Constrain.Declaration where

3−

4−import qualified SourceSyntax.Annotation as A

5−import qualified SourceSyntax.Declaration as D

6−import qualified SourceSyntax.Expression as E

7−import qualified SourceSyntax.Pattern as P

8−import qualified SourceSyntax.Type as T

9−

10−toExpr :: [D.Declaration] -> [E.Def]

11−toExpr = concatMap toDefs

12−

13−toDefs :: D.Declaration -> [E.Def]

14−toDefs decl =

15− case decl of

16− D.Definition def -> [def]

17−

18− D.Datatype name tvars constructors -> concatMap toDefs' constructors

19− where

20− toDefs' (ctor, tipes) =

21− let vars = take (length tipes) arguments

22− tbody = T.Data name $ map T.Var tvars

23− body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars

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

25−

26− D.TypeAlias name _ tipe@(T.Record fields ext) ->

27− [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

28− where

29− args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

30−

31− var = A.none . E.rawVar

32− vars = take (length args) arguments

33−

34− efields = zip (map fst fields) (map var vars)

35− record = case ext of

36− Nothing -> A.none $ E.Record efields

37− Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields

38−

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

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

41− D.TypeAlias _ _ _ -> []

42−

43− D.Port port ->

44− case port of

45− D.Out name expr@(A.A s _) tipe ->

46− [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

47− D.In name tipe ->

48− [ definition name (A.none $ E.PortIn name tipe) tipe ]

49−

50− -- no constraints are needed for fixity declarations

51− D.Fixity _ _ _ -> []

52−

53−

54−arguments :: [String]

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

56−

57−buildFunction :: E.Expr -> [String] -> E.Expr

58−buildFunction body@(A.A s _) vars =

59− foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)

60−

61−definition :: String -> E.Expr -> T.Type -> E.Def

62−definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs+40−36

@@ -8,19 +8,21 @@ import qualified Data.List as List

8import qualified Data.Map as Map

9import qualified Text.PrettyPrint as PP

10

11−import SourceSyntax.Literal as Lit

11+import AST.Literal as Lit

12−import SourceSyntax.Annotation as Ann

12+import AST.Annotation as Ann

13−import SourceSyntax.Expression

13+import AST.Expression.General

14+import qualified AST.Expression.Canonical as Canonical

14−import qualified SourceSyntax.Pattern as P

15+import qualified AST.Pattern as P

15−import qualified SourceSyntax.Type as ST

16+import qualified AST.Type as ST

16−import qualified SourceSyntax.Variable as V

17+import qualified AST.Variable as V

17import Type.Type hiding (Descriptor(..))

18import Type.Type hiding (Descriptor(..))

18import Type.Fragment

19import Type.Fragment

19import qualified Type.Environment as Env

20import qualified Type.Environment as Env

20import qualified Type.Constrain.Literal as Literal

21import qualified Type.Constrain.Literal as Literal

21import qualified Type.Constrain.Pattern as Pattern

22import qualified Type.Constrain.Pattern as Pattern

22

23

23−constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

24+constrain :: Env.Environment -> Canonical.Expr -> Type

25+ -> ErrorT [PP.Doc] IO TypeConstraint

24constrain env (A region expr) tipe =

26constrain env (A region expr) tipe =

25 let list t = Env.get env Env.types "_List" <| t

27 let list t = Env.get env Env.types "_List" <| t

26 and = A region . CAnd

28 and = A region . CAnd

@@ -45,12 +47,14 @@ constrain env (A region expr) tipe =

45 else record (Map.map (\t -> [glTipe t]) decls) baseRec

47 else record (Map.map (\t -> [glTipe t]) decls) baseRec

46 attribute = makeRec Lit.attribute attr

48 attribute = makeRec Lit.attribute attr

47 uniform = makeRec Lit.uniform unif

49 uniform = makeRec Lit.uniform unif

48− varying = makeRec Lit.varying (TermN EmptyRecord1)

50+ varying = makeRec Lit.varying (termN EmptyRecord1)

49 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

50

52

51− Var (V.Raw name)

53+ Var var

52 | name == saveEnvName -> return (A region CSaveEnv)

54 | name == saveEnvName -> return (A region CSaveEnv)

53 | otherwise -> return (name <? tipe)

55 | otherwise -> return (name <? tipe)

56+ where

57+ name = V.toString var

54

58

55 Range lo hi ->

59 Range lo hi ->

56 existsNumber $ \n -> do

60 existsNumber $ \n -> do

@@ -68,7 +72,7 @@ constrain env (A region expr) tipe =

68 exists $ \t2 -> do

72 exists $ \t2 -> do

69 c1 <- constrain env e1 t1

73 c1 <- constrain env e1 t1

70 c2 <- constrain env e2 t2

74 c2 <- constrain env e2 t2

71− return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]

75+ return $ and [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]

72

76

73 Lambda p e ->

77 Lambda p e ->

74 exists $ \t1 ->

78 exists $ \t1 ->

@@ -102,8 +106,8 @@ constrain env (A region expr) tipe =

102 and . (:) ce <$> mapM branch branches

106 and . (:) ce <$> mapM branch branches

103

107

104 Data name exprs ->

108 Data name exprs ->

105− do vars <- forM exprs $ \_ -> liftIO (var Flexible)

109+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

106− let pairs = zip exprs (map VarN vars)

110+ let pairs = zip exprs (map varN vars)

107 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

108 return $ ex vars (cs /\ name <? ctipe)

112 return $ ex vars (cs /\ name <? ctipe)

109 where

113 where

@@ -129,28 +133,28 @@ constrain env (A region expr) tipe =

129

133

130 Modify e fields ->

134 Modify e fields ->

131 exists $ \t -> do

135 exists $ \t -> do

132− oldVars <- forM fields $ \_ -> liftIO (var Flexible)

136+ oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

133− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

134 cOld <- ex oldVars <$> constrain env e (record oldFields t)

138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

135

139

136− newVars <- forM fields $ \_ -> liftIO (var Flexible)

140+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)

137− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

138 let cNew = tipe === record newFields t

142 let cNew = tipe === record newFields t

139

143

140− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

141

145

142 return $ cOld /\ ex newVars (and (cNew : cs))

146 return $ cOld /\ ex newVars (and (cNew : cs))

143

147

144 Record fields ->

148 Record fields ->

145− do vars <- forM fields $ \_ -> liftIO (var Flexible)

149+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)

146− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

147− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

148− recordType = record fields' (TermN EmptyRecord1)

152+ recordType = record fields' (termN EmptyRecord1)

149 return . ex vars . and $ tipe === recordType : cs

153 return . ex vars . and $ tipe === recordType : cs

150

154

151 Markdown _ _ es ->

155 Markdown _ _ es ->

152− do vars <- forM es $ \_ -> liftIO (var Flexible)

156+ do vars <- forM es $ \_ -> liftIO (variable Flexible)

153− let tvars = map VarN vars

157+ let tvars = map varN vars

154 cs <- zipWithM (constrain env) es tvars

158 cs <- zipWithM (constrain env) es tvars

155 return . ex vars $ and ("Text.markdown" <? tipe : cs)

159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

156

160

@@ -169,16 +173,16 @@ constrain env (A region expr) tipe =

169 PortOut _ _ signal ->

173 PortOut _ _ signal ->

170 constrain env signal tipe

174 constrain env signal tipe

171

175

172−constrainDef env info (Definition pattern expr maybeTipe) =

176+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

173 let qs = [] -- should come from the def, but I'm not sure what would live there...

177 let qs = [] -- should come from the def, but I'm not sure what would live there...

174 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

175 in

179 in

176− do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.

180+ do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here.

177 -- Currently, qs is always [].

181 -- Currently, qs is always [].

178 case (pattern, maybeTipe) of

182 case (pattern, maybeTipe) of

179 (P.Var name, Just tipe) -> do

183 (P.Var name, Just tipe) -> do

180− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

184+ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

181− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

182 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

183 (vars, typ) <- Env.instantiateType env tipe Map.empty

187 (vars, typ) <- Env.instantiateType env tipe Map.empty

184 let scheme = Scheme { rigidQuantifiers = [],

188 let scheme = Scheme { rigidQuantifiers = [],

@@ -194,9 +198,9 @@ constrainDef env info (Definition pattern expr maybeTipe) =

194 , fl rigidVars c /\ c1 )

198 , fl rigidVars c /\ c1 )

195

199

196 (P.Var name, Nothing) -> do

200 (P.Var name, Nothing) -> do

197− v <- liftIO $ var Flexible

201+ v <- liftIO $ variable Flexible

198− let tipe = VarN v

202+ let tipe = varN v

199− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

200 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

201 c <- constrain env' expr tipe

205 c <- constrain env' expr tipe

202 return ( schemes

206 return ( schemes

@@ -206,18 +210,18 @@ constrainDef env info (Definition pattern expr maybeTipe) =

206 , c /\ c2

210 , c /\ c2

207 , c1 )

211 , c1 )

208

212

209− _ -> error (show pattern)

213+ _ -> error ("problem in constrainDef with " ++ show pattern)

210

214

211−expandPattern :: Def -> [Def]

215+expandPattern :: Canonical.Def -> [Canonical.Def]

212−expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

216+expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

213 case pattern of

217 case pattern of

214 P.Var _ -> [def]

218 P.Var _ -> [def]

215− _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

219+ _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

216 where

220 where

217 vars = P.boundVarList pattern

221 vars = P.boundVarList pattern

218 x = "$" ++ concat vars

222 x = "$" ++ concat vars

219− mkVar = A r . rawVar

223+ mkVar = A r . localVar

220− toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

224+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

221

225

222try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

223try region computation = do

227try region computation = do

compiler/Type/Constrain/Literal.hs+3−3

@@ -1,8 +1,8 @@

1{-# OPTIONS_GHC -W #-}

2module Type.Constrain.Literal where

3

4−import SourceSyntax.Annotation

4+import AST.Annotation

5−import SourceSyntax.Literal

5+import AST.Literal

6import Type.Type

7import Type.Environment as Env

8

@@ -15,7 +15,7 @@ constrain env region literal tipe =

15

16 litType =

17 case literal of

18− IntNum _ -> VarN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` variable (Is Number)

19 FloatNum _ -> prim "Float"

20 Chr _ -> prim "Char"

21 Str _ -> prim "String"

compiler/Type/Constrain/Pattern.hs+18−15

@@ -9,20 +9,21 @@ import Control.Monad.Error

9import qualified Data.Map as Map

10import qualified Text.PrettyPrint as PP

11

12−import qualified SourceSyntax.Annotation as A

12+import qualified AST.Annotation as A

13−import qualified SourceSyntax.Pattern as P

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as V

14−import SourceSyntax.PrettyPrint (pretty)

15+import AST.PrettyPrint (pretty)

15import Type.Type

16import Type.Type

16import Type.Fragment

17import Type.Fragment

17import Type.Environment as Env

18import Type.Environment as Env

18import qualified Type.Constrain.Literal as Literal

19import qualified Type.Constrain.Literal as Literal

19

20

21

22+constrain :: Environment -> P.CanonicalPattern -> Type

21−constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment

23+ -> ErrorT (A.Region -> PP.Doc) IO Fragment

22constrain env pattern tipe =

24constrain env pattern tipe =

23 let region = A.None (pretty pattern)

25 let region = A.None (pretty pattern)

24 t1 === t2 = A.A region (CEqual t1 t2)

26 t1 === t2 = A.A region (CEqual t1 t2)

25− x <? t = A.A region (CInstance x t)

26 in

27 in

27 case pattern of

28 case pattern of

28 P.Anything -> return emptyFragment

29 P.Anything -> return emptyFragment

@@ -32,23 +33,25 @@ constrain env pattern tipe =

32 return $ emptyFragment { typeConstraint = c }

33 return $ emptyFragment { typeConstraint = c }

33

34

34 P.Var name -> do

35 P.Var name -> do

35− v <- liftIO $ var Flexible

36+ v <- liftIO $ variable Flexible

36 return $ Fragment {

37 return $ Fragment {

37− typeEnv = Map.singleton name (VarN v),

38+ typeEnv = Map.singleton name (varN v),

38 vars = [v],

39 vars = [v],

39− typeConstraint = VarN v === tipe

40+ typeConstraint = varN v === tipe

40 }

41 }

41

42

42 P.Alias name p -> do

43 P.Alias name p -> do

44+ v <- liftIO $ variable Flexible

43 fragment <- constrain env p tipe

45 fragment <- constrain env p tipe

44− return $ fragment {

46+ return $ fragment

45− typeEnv = Map.insert name tipe (typeEnv fragment),

47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)

48+ , vars = v : vars fragment

46− typeConstraint = name <? tipe /\ typeConstraint fragment

49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment

47 }

50 }

48

51

49 P.Data name patterns -> do

52 P.Data name patterns -> do

50− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

53+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

51− let msg = concat [ "Constructor '", name, "' expects ", show kind

54+ let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

52 , " argument", if kind == 1 then "" else "s"

55 , " argument", if kind == 1 then "" else "s"

53 , " but was given ", show (length patterns), "." ]

56 , " but was given ", show (length patterns), "." ]

54 err span = PP.vcat [ PP.text $ "Type error " ++ show span

57 err span = PP.vcat [ PP.text $ "Type error " ++ show span

@@ -63,8 +66,8 @@ constrain env pattern tipe =

63 }

66 }

64

67

65 P.Record fields -> do

68 P.Record fields -> do

66− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

69+ pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

67− let tenv = Map.fromList (map (second VarN) pairs)

70+ let tenv = Map.fromList (map (second varN) pairs)

68 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

71 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

69 return $ Fragment {

72 return $ Fragment {

70 typeEnv = tenv,

73 typeEnv = tenv,

compiler/Type/Environment.hs+84−86

@@ -4,7 +4,6 @@ module Type.Environment where

4import Control.Applicative ((<$>), (<*>))

5import Control.Exception (try, SomeException)

6import Control.Monad

7−import Control.Monad.Trans.Error (ErrorList(..))

8import Control.Monad.Error (ErrorT, throwError, liftIO)

7import Control.Monad.Error (ErrorT, throwError, liftIO)

9import qualified Control.Monad.State as State

8import qualified Control.Monad.State as State

10import qualified Data.Traversable as Traverse

9import qualified Data.Traversable as Traverse

@@ -12,55 +11,59 @@ import qualified Data.Map as Map

12import Data.List (isPrefixOf)

11import Data.List (isPrefixOf)

13import qualified Text.PrettyPrint as PP

12import qualified Text.PrettyPrint as PP

14

13

15−import qualified SourceSyntax.Type as Src

14+import qualified AST.Type as T

16−import SourceSyntax.Module (ADT, Alias)

15+import qualified AST.Variable as V

16+import AST.Module (CanonicalAdt, AdtInfo)

17import Type.Type

18

19type TypeDict = Map.Map String Type

20type VarDict = Map.Map String Variable

21

22−data Environment = Environment {

22+data Environment = Environment

23− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

23+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

24− aliases :: Map.Map String ([String], Src.Type),

25− types :: TypeDict,

24+ , types :: TypeDict

26− value :: TypeDict

25+ , value :: TypeDict

27−}

26+ }

28

27

29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment

28+initialEnvironment :: [CanonicalAdt] -> IO Environment

30−initialEnvironment datatypes aliases = do

29+initialEnvironment datatypes = do

31 types <- makeTypes datatypes

30 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

33− env = Environment {

31+ let env = Environment

34− constructor = Map.empty,

32+ { constructor = Map.empty

35− value = Map.empty,

33+ , value = Map.empty

36− types = types,

34+ , types = types

37− aliases = aliases' }

35+ }

38−

39 return $ env { constructor = makeConstructors env datatypes }

36 return $ env { constructor = makeConstructors env datatypes }

40

37

41−makeTypes :: [ADT] -> IO TypeDict

38+makeTypes :: [CanonicalAdt] -> IO TypeDict

42−makeTypes datatypes =

39+makeTypes datatypes =

43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

40+ do adts <- mapM makeImported datatypes

41+ bs <- mapM makeBuiltin builtins

42+ return (Map.fromList (adts ++ bs))

44 where

43 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

44+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

46−

45+ makeImported (var, _) = do

47− makeCtor (name, _) = do

48− ctor <- VarN <$> namedVar Constant name

46+ tvar <- namedVar Constant var

49− return (name, ctor)

47+ return (V.toString var, varN tvar)

50

48

51− tuple n = ("_Tuple" ++ show n, n)

49+ makeBuiltin :: (String, Int) -> IO (String, Type)

50+ makeBuiltin (name, _) = do

51+ name' <- namedVar Constant (V.builtin name)

52+ return (name, varN name')

52

53

53− kind n names = map (\name -> (name, n)) names

54−

55− builtins :: [(String,Int)]

54+ builtins :: [(String, Int)]

56 builtins = concat [ map tuple [0..9]

55 builtins = concat [ map tuple [0..9]

57 , kind 1 ["_List"]

56 , kind 1 ["_List"]

58 , kind 0 ["Int","Float","Char","String","Bool"]

57 , kind 0 ["Int","Float","Char","String","Bool"]

59 ]

58 ]

59+ where

60+ tuple n = ("_Tuple" ++ show n, n)

61+ kind n names = map (\name -> (name, n)) names

62+

60

63

61

64

62makeConstructors :: Environment

65makeConstructors :: Environment

63− -> [ADT]

66+ -> [CanonicalAdt]

64 -> Map.Map String (IO (Int, [Variable], [Type], Type))

67 -> Map.Map String (IO (Int, [Variable], [Type], Type))

65makeConstructors env datatypes = Map.fromList builtins

68makeConstructors env datatypes = Map.fromList builtins

66 where

69 where

@@ -68,8 +71,8 @@ makeConstructors env datatypes = Map.fromList builtins

68

71

69 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

72 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

70 inst numTVars tipe = do

73 inst numTVars tipe = do

71− vars <- forM [1..numTVars] $ \_ -> var Flexible

74+ vars <- forM [1..numTVars] $ \_ -> variable Flexible

72− let (args, result) = tipe (map VarN vars)

75+ let (args, result) = tipe (map (varN) vars)

73 return (length args, vars, args, result)

76 return (length args, vars, args, result)

74

77

75 tupleCtor n =

78 tupleCtor n =

@@ -83,88 +86,83 @@ makeConstructors env datatypes = Map.fromList builtins

83 ++ concatMap (ctorToType env) datatypes

86 ++ concatMap (ctorToType env) datatypes

84

87

85

88

89+ctorToType :: Environment

90+ -> (V.Canonical, AdtInfo V.Canonical)

86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

91+ -> [(String, IO (Int, [Variable], [Type], Type))]

87−ctorToType env (name, tvars, ctors) =

92+ctorToType env (name, (tvars, ctors)) =

88− zip (map fst ctors) (map inst ctors)

93+ zip (map (V.toString . fst) ctors) (map inst ctors)

89 where

94 where

90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

95+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

91 inst ctor = do

96 inst ctor = do

92− ((args, tipe), (dict,_)) <- State.runStateT (go ctor) (Map.empty, Map.empty)

97+ ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

93 return (length args, Map.elems dict, args, tipe)

98 return (length args, Map.elems dict, args, tipe)

94

99

95

100

96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

101+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

97 go (_, args) = do

102 go (_, args) = do

98 types <- mapM (instantiator env) args

103 types <- mapM (instantiator env) args

99− returnType <- instantiator env (Src.Data name (map Src.Var tvars))

104+ returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))

100 return (types, returnType)

105 return (types, returnType)

101

106

102

107

103get :: Environment -> (Environment -> Map.Map String a) -> String -> a

108get :: Environment -> (Environment -> Map.Map String a) -> String -> a

104−get env subDict key = Map.findWithDefault err key (subDict env)

109+get env subDict key = Map.findWithDefault (error msg) key (subDict env)

105 where

110 where

106− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."

111+ msg = "Could not find type constructor '" ++ key ++ "' while checking types."

107

112

108

113

109freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

110freshDataScheme env name = get env constructor name

115freshDataScheme env name = get env constructor name

111

116

112−instance ErrorList PP.Doc where

113− listMsg str = [PP.text str]

114−

115−instantiateType :: Environment -> Src.Type -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

117+instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type)

116instantiateType env sourceType dict =

118instantiateType env sourceType dict =

117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))

119+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of

120+ case result :: Either SomeException (Type, VarDict) of

119 Left someError -> throwError [ PP.text $ show someError ]

121 Left someError -> throwError [ PP.text $ show someError ]

120− Right (tipe, (dict',_)) -> return (Map.elems dict', tipe)

122+ Right (tipe, dict') -> return (Map.elems dict', tipe)

121

123

122−instantiator :: Environment -> Src.Type

123− -> State.StateT (VarDict, TypeDict) IO Type

124+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

124instantiator env sourceType = go sourceType

125instantiator env sourceType = go sourceType

125 where

126 where

126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

127+ go :: T.CanonicalType -> State.StateT VarDict IO Type

127 go sourceType =

128 go sourceType =

128 case sourceType of

129 case sourceType of

129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130−

131+

131− Src.Var x -> do

132+ T.Var x -> do

132− (dict, aliases) <- State.get

133+ dict <- State.get

133− case (Map.lookup x dict, Map.lookup x aliases) of

134+ case Map.lookup x dict of

134− (_, Just t) -> return t

135− (Just v, _) -> return (VarN v)

135+ Just v -> return (varN v)

136− _ ->

136+ Nothing ->

137− do var <- State.liftIO $ namedVar flex x

137+ do v <- State.liftIO $ namedVar flex (V.local x)

138− State.put (Map.insert x var dict, aliases)

138+ State.put (Map.insert x v dict)

139− return (VarN var)

139+ return (varN v)

140 where

141 flex | "number" `isPrefixOf` x = Is Number

142 | "comparable" `isPrefixOf` x = Is Comparable

143 | "appendable" `isPrefixOf` x = Is Appendable

144 | otherwise = Flexible

145

146− Src.Data name ts -> do

146+ T.Aliased name t -> do

147+ t' <- go t

148+ case t' of

149+ VarN _ v -> return (VarN (Just name) v)

150+ TermN _ term -> return (TermN (Just name) term)

151+

152+ T.Type name ->

153+ case Map.lookup (V.toString name) (types env) of

154+ Just t -> return t

155+ Nothing -> error $ "Could not find type constructor '" ++

156+ V.toString name ++ "' while checking types."

157+

158+ T.App t ts -> do

159+ t' <- go t

147 ts' <- mapM go ts

160 ts' <- mapM go ts

148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of

149− (Just t, _) -> return $ foldl (<|) t ts'

161+ return $ foldl (<|) t' ts'

150− (_, Just (tvars, t)) ->

162+

151− let tvarLen = length tvars

152− msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++

153− " type argument" ++ (if tvarLen == 1 then "" else "s") ++

154− " but was given " ++ show (length ts')

155− in if length ts' /= length tvars then error msg else

156− do (dict, aliases) <- State.get

157− let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases

158− State.put (dict, aliases')

159− t' <- go t

160− State.put (dict, aliases)

161− return t'

162− _ -> error $ "\nCould not find type constructor '" ++

163− name ++ "' while checking types."

164−

165− Src.Record fields ext -> do

163+ T.Record fields ext -> do

166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

164+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

167 ext' <- case ext of

165 ext' <- case ext of

168− Nothing -> return $ TermN EmptyRecord1

166+ Nothing -> return $ termN EmptyRecord1

169− Just x -> go (Src.Var x)

167+ Just x -> go x

170− return $ TermN (Record1 fields' ext')

168+ return $ termN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+51−42

@@ -1,4 +1,4 @@

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

2

3{-| This module contains checks to be run *after* type inference has completed

4successfully. At that point we still need to do occurs checks and ensure that

@@ -7,62 +7,78 @@ successfully. At that point we still need to do occurs checks and ensure that

7module Type.ExtraChecks (mainType, occurs, portTypes) where

8

9import Control.Applicative ((<$>),(<*>))

10+import Control.Monad.Error

10import Control.Monad.State

11import Control.Monad.State

11import qualified Data.Map as Map

12import qualified Data.Map as Map

12import qualified Data.Traversable as Traverse

13import qualified Data.Traversable as Traverse

13import qualified Data.UnionFind.IO as UF

14import qualified Data.UnionFind.IO as UF

14import Text.PrettyPrint as P

15import Text.PrettyPrint as P

15

16

16−import qualified SourceSyntax.Annotation as A

17+import qualified AST.Annotation as A

17−import qualified SourceSyntax.Expression as E

18+import qualified AST.Expression.Canonical as Canonical

18−import qualified SourceSyntax.Helpers as Help

19−import qualified SourceSyntax.PrettyPrint as SPP

19+import qualified AST.PrettyPrint as PP

20−import qualified SourceSyntax.Type as ST

20+import qualified AST.Type as ST

21+import qualified AST.Variable as V

21import qualified Transform.Expression as Expr

22import qualified Transform.Expression as Expr

22import qualified Type.Type as TT

23import qualified Type.Type as TT

23import qualified Type.State as TS

24import qualified Type.State as TS

24−import qualified Type.Alias as Alias

25

26+throw :: [Doc] -> Either [Doc] a

26throw err = Left [ P.vcat err ]

27throw err = Left [ P.vcat err ]

27

28

28−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

29+mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

30+mainType environment =

29−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

31+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32+ mainCheck environment'

30 where

33 where

31− mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)

34+ mainCheck :: (Monad m) => Map.Map String ST.CanonicalType

35+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)

32− mainCheck rules env =

36+ mainCheck env =

33 case Map.lookup "main" env of

37 case Map.lookup "main" env of

34− Nothing -> Right env

38+ Nothing -> return env

35− Just mainType

39+ Just typeOfMain

36− | tipe `elem` acceptable -> Right env

40+ | tipe `elem` acceptable -> return env

37− | otherwise -> throw err

41+ | otherwise -> throwError err

38 where

42 where

39 acceptable = [ "Graphics.Element.Element"

43 acceptable = [ "Graphics.Element.Element"

40 , "Signal.Signal Graphics.Element.Element" ]

44 , "Signal.Signal Graphics.Element.Element" ]

41

45

42− tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

46+ tipe = PP.renderPretty typeOfMain

43 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

47 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

44 , P.text "Instead 'main' has type:\n"

48 , P.text "Instead 'main' has type:\n"

45− , P.nest 4 . SPP.pretty $ Alias.realias rules mainType

49+ , P.nest 4 (PP.pretty typeOfMain)

46 , P.text " " ]

50 , P.text " " ]

47

51

48data Direction = In | Out

52data Direction = In | Out

49

53

50−portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

54+portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

51−portTypes rules expr =

55+portTypes expr =

52− const () <$> Expr.checkPorts (check In) (check Out) expr

56+ case Expr.checkPorts (check In) (check Out) expr of

57+ Left err -> throwError err

58+ Right _ -> return ()

53 where

59 where

54 check = isValid True False False

60 check = isValid True False False

55 isValid isTopLevel seenFunc seenSignal direction name tipe =

61 isValid isTopLevel seenFunc seenSignal direction name tipe =

56 case tipe of

62 case tipe of

57− ST.Data ctor ts

63+ ST.Aliased _ t -> valid t

58− | validConstructor -> mapM_ valid ts

64+

59− | ctor == "Signal.Signal" -> handleSignal ts

65+ ST.Type v

66+ | V.isJson v -> return ()

67+ | V.isPrimitive v -> return ()

60− | otherwise -> err' True "an unsupported type"

68+ | otherwise -> err "an unsupported type"

61− where

69+

62− primitives =

70+ ST.App t [] -> valid t

63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]

71+

64− validConstructor =

72+ ST.App (ST.Type v) [t]

65− ctor `elem` primitives || Help.isTuple ctor

73+ | V.isSignal v -> handleSignal t

74+ | V.isMaybe v -> valid t

75+ | V.isArray v -> valid t

76+ | V.isList v -> valid t

77+

78+ ST.App (ST.Type v) ts

79+ | V.isTuple v -> mapM_ valid ts

80+

81+ ST.App _ _ -> err "an unsupported type"

66

82

67 ST.Var _ -> err "free type variables"

83 ST.Var _ -> err "free type variables"

68

84

@@ -84,30 +100,24 @@ portTypes rules expr =

84 isValid' = isValid False

100 isValid' = isValid False

85 valid = isValid' seenFunc seenSignal direction name

101 valid = isValid' seenFunc seenSignal direction name

86

102

87− handleSignal ts

103+ handleSignal t

88 | seenFunc = err "functions that involve signals"

104 | seenFunc = err "functions that involve signals"

89 | seenSignal = err "signals-of-signals"

105 | seenSignal = err "signals-of-signals"

90− | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

106+ | isTopLevel = isValid' seenFunc True direction name t

91 | otherwise = err "a signal within a data stucture"

107 | otherwise = err "a signal within a data stucture"

92

108

93 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

109 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

94 txt = P.text . concat

110 txt = P.text . concat

95

111

96− err = err' False

112+ err kind =

97− err' couldBeAlias kind =

98 throw $

113 throw $

99 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

114 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

100 , " through port '", name, "' is invalid." ]

115 , " through port '", name, "' is invalid." ]

101 , txt [ "It contains ", kind, ":\n" ]

116 , txt [ "It contains ", kind, ":\n" ]

102− , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"

117+ , P.nest 4 (PP.pretty tipe) <> P.text "\n"

103 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

118 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

104 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]

119 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]

105 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]

120 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]

106− ] ++ if couldBeAlias then aliasWarning else []

107−

108− aliasWarning =

109− [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]

110− , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

111 ]

121 ]

112

122

113occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

123occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

@@ -119,17 +129,16 @@ occurs (name, variable) =

119 desc <- liftIO $ UF.descriptor var

129 desc <- liftIO $ UF.descriptor var

120 case TT.structure desc of

130 case TT.structure desc of

121 Nothing ->

131 Nothing ->

122− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

132+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

123 Just _ ->

133 Just _ ->

124 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

134 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

125 var' <- liftIO $ UF.fresh desc

135 var' <- liftIO $ UF.fresh desc

126 TS.addError (A.None (P.text name)) (Just msg) var var'

136 TS.addError (A.None (P.text name)) (Just msg) var var'

127 where

137 where

128 msg = "Infinite types are not allowed"

138 msg = "Infinite types are not allowed"

129− fallback _ = return $ P.text msg

130

139

131 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

140 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

132− infiniteVars seen var =

141+ infiniteVars seen var =

133 let go = infiniteVars (var:seen) in

142 let go = infiniteVars (var:seen) in

134 if var `elem` seen

143 if var `elem` seen

135 then return [var]

144 then return [var]

compiler/Type/Fragment.hs+2−2

@@ -4,8 +4,8 @@ import qualified Data.List as List

4import qualified Data.Map as Map

5

6import Type.Type

7−import SourceSyntax.Pattern

7+import AST.Pattern

8−import SourceSyntax.Annotation (noneNoDocs)

8+import AST.Annotation (noneNoDocs)

9

10data Fragment = Fragment

11 { typeEnv :: Map.Map String Type

compiler/Type/Inference.hs+74−38

@@ -8,50 +8,86 @@ import qualified Type.Environment as Env

8import qualified Type.Constrain.Expression as TcExpr

9import qualified Type.Solve as Solve

10

11−import SourceSyntax.Module as Module

11+import qualified AST.Annotation as A

12−import SourceSyntax.Annotation (noneNoDocs)

12+import AST.Module as Module

13−import SourceSyntax.Type (Type)

13+import AST.Type (CanonicalType)

14+import qualified AST.Variable as Var

14import Text.PrettyPrint

15import Text.PrettyPrint

15import qualified Type.State as TS

16import qualified Type.State as TS

16import qualified Type.ExtraChecks as Check

17import qualified Type.ExtraChecks as Check

18+import Control.Arrow (first, second)

17import Control.Monad.State (execStateT, forM)

19import Control.Monad.State (execStateT, forM)

18−import Control.Monad.Error (runErrorT, liftIO)

20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

19−import qualified Type.Alias as Alias

20

21

21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

22 -- the IO monad. I don't think that'd be worthwhile.

23 -- the IO monad. I don't think that'd be worthwhile.

23

24

25

25−infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

26+infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

26−infer interfaces modul = unsafePerformIO $ do

27+infer interfaces modul = unsafePerformIO $ runErrorT $ do

28+ (header, constraint) <- genConstraints interfaces modul

29+

30+ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState

31+

32+ () <- case TS.sErrors state of

33+ errors@(_:_) -> throwError errors

34+ [] -> return ()

35+

36+ () <- Check.portTypes (program (body modul))

37+

38+ let header' = Map.delete "::" header

39+ types = Map.difference (TS.sSavedEnv state) header'

40+

41+ Check.mainType types

42+

43+

44+genConstraints :: Interfaces -> CanonicalModule

45+ -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)

46+genConstraints interfaces modul = do

27− env <- Env.initialEnvironment

47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

28− (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

48+

29− (aliases modul ++ concatMap iAliases (Map.elems interfaces))

30− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

31− do (_, vars, args, result) <- Env.freshDataScheme env name

50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

32− return (name, (vars, foldr (T.==>) result args))

51+ return (name, (vars, foldr (T.==>) result args))

33−

52+

34− attemptConstraint <- runErrorT $ do

53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

35− importedVars <-

54+

36− forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->

37− (,) name `fmap` Env.instantiateType env tipe Map.empty

38−

39− let allTypes = ctors ++ importedVars

55+ let allTypes = concat (ctors : importedVars)

40− vars = concatMap (fst . snd) allTypes

56+ vars = concatMap (fst . snd) allTypes

41− header = Map.map snd (Map.fromList allTypes)

57+ header = Map.map snd (Map.fromList allTypes)

42− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

58+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]

43−

59+

44− fvar <- liftIO $ T.var T.Flexible

60+ fvar <- liftIO $ T.variable T.Flexible

45− c <- TcExpr.constrain env (program modul) (T.VarN fvar)

61+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)

46− return (header, environ c)

62+ return (header, environ c)

47−

63+

48− case attemptConstraint of

64+

49− Left err -> return $ Left err

65+canonicalizeValues :: Env.Environment -> (String, Interface)

50− Right (header, constraint) -> do

66+ -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]

51− state <- execStateT (Solve.solve constraint) TS.initialState

67+canonicalizeValues env (moduleName, iface) =

52− let rules = Alias.rules interfaces (aliases modul) (imports modul)

68+ forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do

53− case TS.sErrors state of

69+ tipe' <- Env.instantiateType env tipe Map.empty

54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

70+ return (moduleName ++ "." ++ name, tipe')

55− [] -> case Check.portTypes rules (program modul) of

71+

56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

72+canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

57− Left err -> return (Left err)

73+canonicalizeAdts interfaces modul =

74+ localAdts ++ importedAdts

75+ where

76+ localAdts :: [CanonicalAdt]

77+ localAdts = format (Module.getName modul, datatypes (body modul))

78+

79+ importedAdts :: [CanonicalAdt]

80+ importedAdts = concatMap (format . second iAdts) (Map.toList interfaces)

81+

82+ format :: (String, Module.ADTs) -> [CanonicalAdt]

83+ format (home, adts) =

84+ map canonical (Map.toList adts)

85+ where

86+ canonical :: (String, AdtInfo String) -> CanonicalAdt

87+ canonical (name, (tvars, ctors)) =

88+ ( toVar name

89+ , (tvars, map (first toVar) ctors)

90+ )

91+

92+ toVar :: String -> Var.Canonical

93+ toVar = Var.Canonical (Var.Module home)

compiler/Type/PrettyPrint.hs+3−3

@@ -2,15 +2,15 @@

2module Type.PrettyPrint where

3

4import Text.PrettyPrint

5−import qualified SourceSyntax.PrettyPrint as Src

5+import qualified AST.PrettyPrint as Src

6

7data ParensWhen = Fn | App | Never

8

9class PrettyType a where

10 pretty :: ParensWhen -> a -> Doc

11

12+commaSep :: [Doc] -> Doc

12commaSep docs = sep (punctuate comma docs)

13commaSep docs = sep (punctuate comma docs)

13

14

15+parensIf :: Bool -> Doc -> Doc

14parensIf bool doc = if bool then parens doc else doc

16parensIf bool doc = if bool then parens doc else doc

15−

16−reprime = Src.reprime

compiler/Type/Solve.hs+31−27

@@ -11,7 +11,7 @@ import Type.Type

11import Type.Unify

12import qualified Type.ExtraChecks as Check

13import qualified Type.State as TS

14−import qualified SourceSyntax.Annotation as A

14+import qualified AST.Annotation as A

15

16

17-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -21,9 +21,9 @@ generalize youngPool = do

21 youngMark <- TS.uniqueMark

22 let youngRank = TS.maxRank youngPool

23 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

25 liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank desc) [var] dict

26+ return $ Map.insertWith (++) (rank descriptor) [var] dict

27

28 -- Sort the youngPool variables by rank.

29 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -32,7 +32,8 @@ generalize youngPool = do

32 -- start at low ranks so that we only have to pass

33 -- over the information once.

34 visitedMark <- TS.uniqueMark

35− mapM (\(poolRank, vars) -> mapM (adjustRank youngMark visitedMark poolRank) vars) (Map.toList rankDict)

35+ forM (Map.toList rankDict) $ \(poolRank, vars) ->

36+ mapM (adjustRank youngMark visitedMark poolRank) vars

36

37

37 -- For variables that have rank lowerer than youngRank, register them in

38 -- For variables that have rank lowerer than youngRank, register them in

38 -- the old pool if they are not redundant.

39 -- the old pool if they are not redundant.

@@ -64,35 +65,38 @@ generalize youngPool = do

64-- adjust the ranks of variables such that ranks never increase as you

65-- adjust the ranks of variables such that ranks never increase as you

65-- move deeper into a variable.

66-- move deeper into a variable.

66adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67−adjustRank youngMark visitedMark groupRank variable =

68+adjustRank youngMark visitedMark groupRank var =

68− let adjust = adjustRank youngMark visitedMark groupRank in

69+ do descriptor <- liftIO $ UF.descriptor var

69− do desc <- liftIO $ UF.descriptor variable

70 case () of

71− () | mark desc == youngMark ->

71+ () | mark descriptor == youngMark ->

72 do -- Set the variable as marked first because it may be cyclic.

73− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }

73+ liftIO $ UF.modifyDescriptor var $ \desc ->

74− rank' <- case structure desc of

74+ desc { mark = visitedMark }

75− Nothing -> return groupRank

75+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

76− Just term ->

76+ liftIO $ UF.modifyDescriptor var $ \desc ->

77− case term of

77+ desc { rank = rank' }

78− App1 a b -> max `liftM` adjust a `ap` adjust b

79− Fun1 a b -> max `liftM` adjust a `ap` adjust b

80− Var1 x -> adjust x

81− EmptyRecord1 -> return outermostRank

82− Record1 fields extension ->

83− do ranks <- mapM adjust (concat (Map.elems fields))

84− rnk <- adjust extension

85− return . maximum $ rnk : ranks

86− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { rank = rank' }

87 return rank'

78 return rank'

88

79

89− | mark desc /= visitedMark ->

80+ | mark descriptor /= visitedMark ->

90− do let rank' = min groupRank (rank desc)

81+ do let rank' = min groupRank (rank descriptor)

91− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

82+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

92 return rank'

83 return rank'

93

84

94− | otherwise -> return (rank desc)

85+ | otherwise -> return (rank descriptor)

86+

87+ where

88+ adjust = adjustRank youngMark visitedMark groupRank

95

89

90+ adjustTerm term =

91+ case term of

92+ App1 a b -> max `liftM` adjust a `ap` adjust b

93+ Fun1 a b -> max `liftM` adjust a `ap` adjust b

94+ Var1 x -> adjust x

95+ EmptyRecord1 -> return outermostRank

96+ Record1 fields extension ->

97+ do ranks <- mapM adjust (concat (Map.elems fields))

98+ rnk <- adjust extension

99+ return . maximum $ rnk : ranks

96

100

97

101

98solve :: TypeConstraint -> StateT TS.SolverState IO ()

102solve :: TypeConstraint -> StateT TS.SolverState IO ()

@@ -129,7 +133,7 @@ solve (A.A region constraint) =

129 case Map.lookup name env of

133 case Map.lookup name env of

130 Just tipe -> TS.makeInstance tipe

134 Just tipe -> TS.makeInstance tipe

131 Nothing

135 Nothing

132− | List.isPrefixOf "Native." name -> liftIO (var Flexible)

136+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

133 | otherwise ->

137 | otherwise ->

134 error ("Could not find '" ++ name ++ "' when solving type constraints.")

138 error ("Could not find '" ++ name ++ "' when solving type constraints.")

135

139

compiler/Type/State.hs+40−35

@@ -1,16 +1,15 @@

1{-# OPTIONS_GHC -W #-}

2module Type.State where

3

4−import Control.Applicative ((<$>),(<*>), Applicative)

4+import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )

5import Control.Monad.State

6import qualified Data.Map as Map

7import qualified Data.Traversable as Traversable

8import qualified Data.UnionFind.IO as UF

9

10−import qualified SourceSyntax.Annotation as A

10+import qualified AST.Annotation as A

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import qualified Type.Alias as Alias

14import Type.Type

13import Type.Type

15

14

16-- Pool

15-- Pool

@@ -18,10 +17,10 @@ import Type.Type

18-- The rank of each variable is less than or equal to the pool's "maxRank"

17-- The rank of each variable is less than or equal to the pool's "maxRank"

19-- The young pool exists to make it possible to identify these vars in constant time.

18-- The young pool exists to make it possible to identify these vars in constant time.

20

19

21−data Pool = Pool {

20+data Pool = Pool

22− maxRank :: Int,

21+ { maxRank :: Int

23− inhabitants :: [Variable]

22+ , inhabitants :: [Variable]

24−} deriving Show

23+ } deriving Show

25

24

26emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

25emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

27

26

@@ -33,7 +32,7 @@ data SolverState = SS {

33 sSavedEnv :: Env,

32 sSavedEnv :: Env,

34 sPool :: Pool,

33 sPool :: Pool,

35 sMark :: Int,

34 sMark :: Int,

36− sErrors :: [Alias.Rules -> IO P.Doc]

35+ sErrors :: [P.Doc]

37}

36}

38

37

39initialState = SS {

38initialState = SS {

@@ -47,13 +46,15 @@ initialState = SS {

47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

49

48

49+addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor

50+ -> StateT SolverState IO ()

50addError region hint t1 t2 =

51addError region hint t1 t2 =

51− modify $ \state -> state { sErrors = makeError : sErrors state }

52+ do err <- liftIO makeError

53+ modify $ \state -> state { sErrors = err : sErrors state }

52 where

54 where

53− makeError rules = do

55+ makeError = do

54− let prettiest = pretty . Alias.realias rules

56+ t1' <- pretty <$> toSrcType t1

55− t1' <- prettiest <$> toSrcType t1

57+ t2' <- pretty <$> toSrcType t2

56− t2' <- prettiest <$> toSrcType t2

57 return . P.vcat $

58 return . P.vcat $

58 [ P.text "Type error" <+> pretty region <> P.colon

59 [ P.text "Type error" <+> pretty region <> P.colon

59 , maybe P.empty P.text hint

60 , maybe P.empty P.text hint

@@ -103,17 +104,20 @@ introduce variable = do

103flatten :: Type -> StateT SolverState IO Variable

104flatten :: Type -> StateT SolverState IO Variable

104flatten term =

105flatten term =

105 case term of

106 case term of

106− VarN v -> return v

107+ VarN maybeAlias v -> do

107− TermN t -> do

108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

109+ return v

110+ TermN maybeAlias t -> do

108 flatStructure <- traverseTerm flatten t

111 flatStructure <- traverseTerm flatten t

109 pool <- getPool

112 pool <- getPool

110− var <- liftIO . UF.fresh $ Descriptor {

113+ var <- liftIO . UF.fresh $ Descriptor

111− structure = Just flatStructure,

114+ { structure = Just flatStructure

112− rank = maxRank pool,

115+ , rank = maxRank pool

113− flex = Flexible,

116+ , flex = Flexible

114− name = Nothing,

117+ , name = Nothing

115− copy = Nothing,

118+ , copy = Nothing

116− mark = noMark

119+ , mark = noMark

120+ , alias = maybeAlias

117 }

121 }

118 register var

122 register var

119

123

@@ -139,18 +143,19 @@ makeCopy alreadyCopied variable = do

139

143

140 | otherwise -> do

144 | otherwise -> do

141 pool <- getPool

145 pool <- getPool

142− newVar <- liftIO $ UF.fresh $ Descriptor {

146+ newVar <- liftIO $ UF.fresh $ Descriptor

143− structure = Nothing,

147+ { structure = Nothing

144− rank = maxRank pool,

148+ , rank = maxRank pool

145− mark = noMark,

149+ , mark = noMark

146− flex = case flex desc of

150+ , flex = case flex desc of

147− Is s -> Is s

151+ Is s -> Is s

148− _ -> Flexible,

152+ _ -> Flexible

149− copy = Nothing,

153+ , copy = Nothing

150− name = case flex desc of

154+ , name = case flex desc of

151− Rigid -> Nothing

155+ Rigid -> Nothing

152− _ -> name desc

156+ _ -> name desc

153− }

157+ , alias = Nothing

158+ }

154 register newVar

159 register newVar

155

160

156 -- Link the original variable to the new variable. This lets us

161 -- Link the original variable to the new variable. This lets us

compiler/Type/Type.hs+136−103

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Type where

2module Type.Type where

2

3

3import qualified Data.Char as Char

4import qualified Data.Char as Char

@@ -8,12 +9,13 @@ import Type.PrettyPrint

8import Text.PrettyPrint as P

9import Text.PrettyPrint as P

9import System.IO.Unsafe

10import System.IO.Unsafe

10import Control.Applicative ((<$>),(<*>))

11import Control.Applicative ((<$>),(<*>))

11−import Control.Monad.State

12+import Control.Monad.State (StateT, get, put, execStateT, runStateT)

12−import Control.Monad.Error

13+import Control.Monad.Error (ErrorT, Error, liftIO)

13import Data.Traversable (traverse)

14import Data.Traversable (traverse)

14−import SourceSyntax.Annotation

15+import AST.Annotation

15−import SourceSyntax.Helpers (isTuple)

16+import qualified AST.PrettyPrint as PP

16−import qualified SourceSyntax.Type as Src

17+import qualified AST.Type as T

18+import qualified AST.Variable as Var

17

19

18data Term1 a

20data Term1 a

19 = App1 a a

21 = App1 a a

@@ -24,18 +26,24 @@ data Term1 a

24 deriving Show

26 deriving Show

25

27

26data TermN a

28data TermN a

27− = VarN a

29+ = VarN (Maybe Var.Canonical) a

28− | TermN (Term1 (TermN a))

30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))

29 deriving Show

31 deriving Show

30

32

33+varN :: a -> TermN a

34+varN = VarN Nothing

35+

36+termN :: (Term1 (TermN a)) -> TermN a

37+termN = TermN Nothing

38+

31record :: Map.Map String [TermN a] -> TermN a -> TermN a

39record :: Map.Map String [TermN a] -> TermN a -> TermN a

32−record fs rec = TermN (Record1 fs rec)

40+record fs rec = termN (Record1 fs rec)

33

41

34type Type = TermN Variable

42type Type = TermN Variable

35type Variable = UF.Point Descriptor

43type Variable = UF.Point Descriptor

36

44

37type SchemeName = String

45type SchemeName = String

38−type TypeName = String

46+type TypeName = Var.Canonical

39

47

40type Constraint a b = Located (BasicConstraint a b)

48type Constraint a b = Located (BasicConstraint a b)

41data BasicConstraint a b

49data BasicConstraint a b

@@ -57,6 +65,7 @@ data Scheme a b = Scheme {

57type TypeConstraint = Constraint Type Variable

65type TypeConstraint = Constraint Type Variable

58type TypeScheme = Scheme Type Variable

66type TypeScheme = Scheme Type Variable

59

67

68+monoscheme :: Map.Map String a -> Scheme a b

60monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

69monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

61

70

62infixl 8 /\

71infixl 8 /\

@@ -70,23 +79,31 @@ a@(A _ c1) /\ b@(A _ c2) =

70

79

71infixr 9 ==>

80infixr 9 ==>

72(==>) :: Type -> Type -> Type

81(==>) :: Type -> Type -> Type

73−a ==> b = TermN (Fun1 a b)

82+a ==> b = termN (Fun1 a b)

74−

83+

75−f <| a = TermN (App1 f a)

84+(<|) :: TermN a -> TermN a -> TermN a

76−

85+f <| a = termN (App1 f a)

77−data Descriptor = Descriptor {

86+

78− structure :: Maybe (Term1 Variable),

87+data Descriptor = Descriptor

79− rank :: Int,

88+ { structure :: Maybe (Term1 Variable)

80− flex :: Flex,

89+ , rank :: Int

81− name :: Maybe TypeName,

90+ , flex :: Flex

82− copy :: Maybe Variable,

91+ , name :: Maybe TypeName

83− mark :: Int

92+ , copy :: Maybe Variable

84−} deriving Show

93+ , mark :: Int

85−

94+ , alias :: Maybe Var.Canonical

95+ } deriving Show

96+

97+noRank :: Int

86noRank = -1

98noRank = -1

87−outermostRank = 0 :: Int

88

99

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

89noMark = 0

104noMark = 0

105+

106+initialMark :: Int

90initialMark = 1

107initialMark = 1

91

108

92data Flex = Rigid | Flexible | Constant | Is SuperType

109data Flex = Rigid | Flexible | Constant | Is SuperType

@@ -95,34 +112,26 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95data SuperType = Number | Comparable | Appendable

112data SuperType = Number | Comparable | Appendable

96 deriving (Show, Eq)

113 deriving (Show, Eq)

97

114

98−namedVar :: Flex -> String -> IO Variable

115+namedVar :: Flex -> Var.Canonical -> IO Variable

99−namedVar flex name = UF.fresh $ Descriptor {

116+namedVar flex name = UF.fresh $ Descriptor

100− structure = Nothing,

117+ { structure = Nothing

101− rank = noRank,

118+ , rank = noRank

102− flex = flex,

119+ , flex = flex

103− name = Just name,

120+ , name = Just name

104− copy = Nothing,

121+ , copy = Nothing

105− mark = noMark

122+ , mark = noMark

123+ , alias = Nothing

106 }

124 }

107

125

108−var :: Flex -> IO Variable

126+variable :: Flex -> IO Variable

109−var flex = UF.fresh $ Descriptor {

127+variable flex = UF.fresh $ Descriptor

110− structure = Nothing,

128+ { structure = Nothing

111− rank = noRank,

129+ , rank = noRank

112− flex = flex,

130+ , flex = flex

113− name = Nothing,

131+ , name = Nothing

114− copy = Nothing,

132+ , copy = Nothing

115− mark = noMark

133+ , mark = noMark

116− }

134+ , alias = Nothing

117−

118−structuredVar :: Term1 Variable -> IO Variable

119−structuredVar structure = UF.fresh $ Descriptor {

120− structure = Just structure,

121− rank = noRank,

122− flex = Flexible,

123− name = Nothing,

124− copy = Nothing,

125− mark = noMark

126 }

135 }

127

136

128

137

@@ -138,13 +147,13 @@ fl rqs constraint@(A ann _) =

138

147

139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

148exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

140exists f = do

149exists f = do

141− v <- liftIO $ var Flexible

150+ v <- liftIO $ variable Flexible

142− ex [v] <$> f (VarN v)

151+ ex [v] <$> f (varN v)

143

152

144existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

153existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

145existsNumber f = do

154existsNumber f = do

146− v <- liftIO $ var (Is Number)

155+ v <- liftIO $ variable (Is Number)

147− ex [v] <$> f (VarN v)

156+ ex [v] <$> f (varN v)

148

157

149

158

150instance Show a => Show (UF.Point a) where

159instance Show a => Show (UF.Point a) where

@@ -187,23 +196,32 @@ instance PrettyType a => PrettyType (Term1 a) where

187 prettyExt = prty ext

196 prettyExt = prty ext

188 extend | P.render prettyExt == "{}" = P.empty

197 extend | P.render prettyExt == "{}" = P.empty

189 | otherwise = prettyExt <+> P.text "|"

198 | otherwise = prettyExt <+> P.text "|"

190− mkPretty f t = P.text (reprime f) <+> P.text ":" <+> prty t

199+ mkPretty f t = P.text f <+> P.text ":" <+> prty t

191 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

200 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

192

201

193

202

194instance PrettyType a => PrettyType (TermN a) where

203instance PrettyType a => PrettyType (TermN a) where

195 pretty when term =

204 pretty when term =

196 case term of

205 case term of

197− VarN x -> pretty when x

206+ VarN alias x -> either alias (pretty when x)

198− TermN t1 -> pretty when t1

207+ TermN alias t1 -> either alias (pretty when t1)

199−

208+ where

209+ either maybeAlias doc =

210+ case maybeAlias of

211+ Just alias -> PP.pretty alias

212+ Nothing -> doc

200

213

201instance PrettyType Descriptor where

214instance PrettyType Descriptor where

202− pretty when desc =

215+ pretty when desc = do

203− case (structure desc, name desc) of

216+ case (alias desc, structure desc, name desc) of

204− (Just term, _) -> pretty when term

217+ (Just name, _, _) -> PP.pretty name

205− (_, Just name) -> if not (isTuple name) then P.text (reprime name) else

218+ (_, Just term, _) -> pretty when term

206− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

219+ (_, _, Just name)

220+ | Var.isTuple name ->

221+ P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','

222+ | otherwise ->

223+ P.text (Var.toString name)

224+

207 _ -> P.text "?"

225 _ -> P.text "?"

208

226

209

227

@@ -269,7 +287,7 @@ addNames value = do

269 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

287 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

270 let vars = map head . List.group $ List.sort rawVars

288 let vars = map head . List.group $ List.sort rawVars

271 suffix s = map (++s) (map (:[]) ['a'..'z'])

289 suffix s = map (++s) (map (:[]) ['a'..'z'])

272− allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

290+ allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

273 okayVars = filter (`notElem` vars) allVars

291 okayVars = filter (`notElem` vars) allVars

274 runStateT (crawl rename value) (okayVars, 0, 0, 0)

292 runStateT (crawl rename value) (okayVars, 0, 0, 0)

275 return value

293 return value

@@ -277,23 +295,20 @@ addNames value = do

277 getNames desc state@(vars, a, b, c) =

295 getNames desc state@(vars, a, b, c) =

278 let name' = name desc in

296 let name' = name desc in

279 case name' of

297 case name' of

280− Just var -> (name', (var:vars, a, b, c))

298+ Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

281− Nothing -> (name', state)

299+ _ -> (name', state)

282

300

283 rename desc state@(vars, a, b, c) =

301 rename desc state@(vars, a, b, c) =

284 case name desc of

302 case name desc of

285 Just var -> (Just var, state)

303 Just var -> (Just var, state)

286 Nothing ->

304 Nothing ->

287 case flex desc of

305 case flex desc of

288− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

306+ Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

289− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

307+ Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

290− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

308+ Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

291− other -> (Just $ head vars, (tail vars, a, b, c))

309+ _ -> (local $ head vars, (tail vars, a, b, c))

292− where mark = case other of

310+ where

293− Flexible -> ""

311+ local v = Just (Var.local v)

294− Rigid -> "!"

295− Constant -> "#"

296−

297

312

298type CrawlState = ([String], Int, Int, Int)

313type CrawlState = ([String], Int, Int, Int)

299

314

@@ -329,8 +344,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

329instance Crawl t => Crawl (TermN t) where

344instance Crawl t => Crawl (TermN t) where

330 crawl nextState tipe =

345 crawl nextState tipe =

331 case tipe of

346 case tipe of

332− VarN x -> VarN <$> crawl nextState x

347+ VarN a x -> VarN a <$> crawl nextState x

333− TermN term -> TermN <$> crawl nextState term

348+ TermN a term -> TermN a <$> crawl nextState term

334

349

335instance Crawl t => Crawl (Term1 t) where

350instance Crawl t => Crawl (Term1 t) where

336 crawl nextState term =

351 crawl nextState term =

@@ -359,50 +374,68 @@ instance Crawl Descriptor where

359 return $ desc { name = name', structure = structure' }

374 return $ desc { name = name', structure = structure' }

360

375

361

376

362−toSrcType :: Variable -> IO Src.Type

377+toSrcType :: Variable -> IO T.CanonicalType

363−toSrcType variable = do

378+toSrcType var =

364− desc <- UF.descriptor =<< addNames variable

379+ do desc <- UF.descriptor =<< addNames var

365− case structure desc of

380+ srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

366− Just term ->

381+ return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

382+ where

383+ backupSrcType desc =

384+ case name desc of

385+ Just v@(Var.Canonical _ x@(c:_))

386+ | Char.isLower c -> return (T.Var x)

387+ | otherwise -> return $ T.Type v

388+

389+ _ -> error $ concat

390+ [ "Problem converting the following type "

391+ , "from a type-checker type to a source-syntax type:"

392+ , P.render (pretty Never var) ]

393+

394+ termToSrcType term =

367 case term of

395 case term of

368 App1 a b -> do

396 App1 a b -> do

369− Src.Data name ts <- toSrcType a

397+ a' <- toSrcType a

370 b' <- toSrcType b

398 b' <- toSrcType b

371− return (Src.Data name (ts ++ [b']))

399+ case a' of

372− Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

400+ T.App f args -> return $ T.App f (args ++ [b'])

401+ _ -> return $ T.App a' [b']

402+

403+ Fun1 a b -> T.Lambda <$> toSrcType a <*> toSrcType b

404+

373 Var1 a -> toSrcType a

405 Var1 a -> toSrcType a

374− EmptyRecord1 -> return $ Src.Record [] Nothing

406+

407+ EmptyRecord1 -> return $ T.Record [] Nothing

408+

375 Record1 tfields extension -> do

409 Record1 tfields extension -> do

376 fields' <- traverse (mapM toSrcType) tfields

410 fields' <- traverse (mapM toSrcType) tfields

377 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

411 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

378− ext' <- toSrcType extension

412+ ext' <- dealias <$> toSrcType extension

379 return $ case ext' of

413 return $ case ext' of

380− Src.Record fs ext -> Src.Record (fs ++ fields) ext

414+ T.Record fs ext -> T.Record (fs ++ fields) ext

381− Src.Var x -> Src.Record fields (Just x)

415+ T.Var _ -> T.Record fields (Just ext')

382 _ -> error "Used toSrcType on a type that is not well-formed"

416 _ -> error "Used toSrcType on a type that is not well-formed"

383− Nothing ->

417+

384− case name desc of

418+ dealias :: T.CanonicalType -> T.CanonicalType

385− Just x@(c:_) | Char.isLower c -> return (Src.Var x)

419+ dealias t =

386− | otherwise -> return (Src.Data x [])

420+ case t of

387− _ -> error $ concat

421+ T.Aliased _ t' -> t'

388− [ "Problem converting the following type "

422+ _ -> t

389− , "from a type-checker type to a source-syntax type:"

423+

390− , P.render (pretty Never variable) ]

391

424

392data AppStructure = List Variable | Tuple [Variable] | Other

425data AppStructure = List Variable | Tuple [Variable] | Other

393

426

394collectApps :: Variable -> IO AppStructure

427collectApps :: Variable -> IO AppStructure

395−collectApps variable = go [] variable

428+collectApps var = go [] var

396 where

429 where

397− go vars variable = do

430+ go vars var = do

398− desc <- UF.descriptor variable

431+ desc <- UF.descriptor var

399 case (structure desc, vars) of

432 case (structure desc, vars) of

400 (Nothing, [v]) -> case name desc of

433 (Nothing, [v]) -> case name desc of

401− Just "_List" -> return (List v)

434+ Just n | Var.isList n -> return (List v)

402− _ -> return Other

435+ _ -> return Other

403 (Nothing, vs) -> case name desc of

436 (Nothing, vs) -> case name desc of

404− Just ctor | isTuple ctor -> return (Tuple vs)

437+ Just n | Var.isTuple n -> return (Tuple vs)

405− _ -> return Other

438+ _ -> return Other

406 (Just term, _) -> case term of

439 (Just term, _) -> case term of

407 App1 a b -> go (vars ++ [b]) a

440 App1 a b -> go (vars ++ [b]) a

408 _ -> return Other

441 _ -> return Other

compiler/Type/Unify.hs+81−52

@@ -1,11 +1,14 @@

1{-# OPTIONS_GHC -W #-}

2module Type.Unify (unify) where

3

4+import Control.Applicative ((<|>))

4import Control.Monad.State

5import Control.Monad.State

6+import qualified Data.List as List

5import qualified Data.Map as Map

7import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

8import qualified Data.Maybe as Maybe

7import qualified Data.UnionFind.IO as UF

9import qualified Data.UnionFind.IO as UF

8−import qualified SourceSyntax.Annotation as A

10+import qualified AST.Annotation as A

11+import qualified AST.Variable as Var

9import qualified Type.State as TS

12import qualified Type.State as TS

10import Type.Type

13import Type.Type

11import Type.PrettyPrint

14import Type.PrettyPrint

@@ -23,64 +26,55 @@ actuallyUnify region variable1 variable2 = do

23 desc2 <- liftIO $ UF.descriptor variable2

26 desc2 <- liftIO $ UF.descriptor variable2

24 let unify' = unify region

27 let unify' = unify region

25

28

26− name' :: Maybe String

29+ (name', flex', rank', alias') = combinedDescriptors desc1 desc2

27− name' = case (name desc1, name desc2) of

28− (Just name1, Just name2) ->

29− case (flex desc1, flex desc2) of

30− (_, Flexible) -> Just name1

31− (Flexible, _) -> Just name2

32− (Is Number, Is _) -> Just name1

33− (Is _, Is Number) -> Just name2

34− (Is _, Is _) -> Just name1

35− (_, _) -> Nothing

36− (Just name1, _) -> Just name1

37− (_, Just name2) -> Just name2

38− _ -> Nothing

39−

40− flex' :: Flex

41− flex' = case (flex desc1, flex desc2) of

42− (f, Flexible) -> f

43− (Flexible, f) -> f

44− (Is Number, Is _) -> Is Number

45− (Is _, Is Number) -> Is Number

46− (Is super, Is _) -> Is super

47− (_, _) -> Flexible

48−

49− rank' :: Int

50− rank' = min (rank desc1) (rank desc2)

51

30

52 merge1 :: StateT TS.SolverState IO ()

31 merge1 :: StateT TS.SolverState IO ()

53 merge1 = liftIO $ do

32 merge1 = liftIO $ do

54 if rank desc1 < rank desc2 then UF.union variable2 variable1

33 if rank desc1 < rank desc2 then UF.union variable2 variable1

55 else UF.union variable1 variable2

34 else UF.union variable1 variable2

56 UF.modifyDescriptor variable1 $ \desc ->

35 UF.modifyDescriptor variable1 $ \desc ->

57− desc { structure = structure desc1, flex = flex', name = name' }

36+ desc { structure = structure desc1

37+ , flex = flex'

38+ , name = name'

39+ , alias = alias'

40+ }

58

41

59 merge2 :: StateT TS.SolverState IO ()

42 merge2 :: StateT TS.SolverState IO ()

60 merge2 = liftIO $ do

43 merge2 = liftIO $ do

61 if rank desc1 < rank desc2 then UF.union variable2 variable1

44 if rank desc1 < rank desc2 then UF.union variable2 variable1

62 else UF.union variable1 variable2

45 else UF.union variable1 variable2

63 UF.modifyDescriptor variable2 $ \desc ->

46 UF.modifyDescriptor variable2 $ \desc ->

64− desc { structure = structure desc2, flex = flex', name = name' }

47+ desc { structure = structure desc2

48+ , flex = flex'

49+ , name = name'

50+ , alias = alias'

51+ }

65

52

66 merge = if rank desc1 < rank desc2 then merge1 else merge2

53 merge = if rank desc1 < rank desc2 then merge1 else merge2

67

54

68 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

55 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

69 fresh structure = do

56 fresh structure = do

70− var <- liftIO . UF.fresh $ Descriptor {

57+ v <- liftIO . UF.fresh $ Descriptor

71− structure = structure, rank = rank', flex = flex',

58+ { structure = structure

72− name = name', copy = Nothing, mark = noMark

59+ , rank = rank'

73− }

60+ , flex = flex'

74− TS.register var

61+ , name = name'

75−

62+ , copy = Nothing

76− flexAndUnify var = do

63+ , mark = noMark

77− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

64+ , alias = alias'

65+ }

66+ TS.register v

67+

68+ flexAndUnify v = do

69+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

78 unify' variable1 variable2

70 unify' variable1 variable2

79

71

80− unifyNumber svar name

72+ unifyNumber svar (Var.Canonical home name) =

81− | name `elem` ["Int","Float","number"] = flexAndUnify svar

73+ case home of

82− | otherwise = TS.addError region (Just hint) variable1 variable2

74+ Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

83− where hint = "A number must be an Int or Float."

75+ Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

76+ _ -> let hint = "A number must be an Int or Float."

77+ in TS.addError region (Just hint) variable1 variable2

84

78

85 comparableError maybe =

79 comparableError maybe =

86 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

80 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

@@ -90,22 +84,24 @@ actuallyUnify region variable1 variable2 = do

90 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

84 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

91 where msg = "An appendable must be of type String, List, or Text."

85 where msg = "An appendable must be of type String, List, or Text."

92

86

93− unifyComparable var name

87+ unifyComparable v (Var.Canonical home name) =

94− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

88+ case home of

95− | otherwise = comparableError Nothing

89+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

90+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

91+ _ -> comparableError Nothing

96

92

97 unifyComparableStructure varSuper varFlex =

93 unifyComparableStructure varSuper varFlex =

98 do struct <- liftIO $ collectApps varFlex

94 do struct <- liftIO $ collectApps varFlex

99 case struct of

95 case struct of

100 Other -> comparableError Nothing

96 Other -> comparableError Nothing

101 List v -> do flexAndUnify varSuper

97 List v -> do flexAndUnify varSuper

102− unify' v =<< liftIO (var $ Is Comparable)

98+ unify' v =<< liftIO (variable $ Is Comparable)

103 Tuple vs

99 Tuple vs

104 | length vs > 6 ->

100 | length vs > 6 ->

105 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

101 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

106 | otherwise ->

102 | otherwise ->

107 do flexAndUnify varSuper

103 do flexAndUnify varSuper

108− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

104+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

109 zipWithM_ unify' vs cmpVars

105 zipWithM_ unify' vs cmpVars

110

106

111 unifyAppendable varSuper varFlex =

107 unifyAppendable varSuper varFlex =

@@ -114,10 +110,10 @@ actuallyUnify region variable1 variable2 = do

114 List _ -> flexAndUnify varSuper

110 List _ -> flexAndUnify varSuper

115 _ -> appendableError Nothing

111 _ -> appendableError Nothing

116

112

117− rigidError variable = TS.addError region (Just hint) variable1 variable2

113+ rigidError var = TS.addError region (Just hint) variable1 variable2

118 where

114 where

119− var = "'" ++ render (pretty Never variable) ++ "'"

115+ var' = "'" ++ render (pretty Never var) ++ "'"

120− hint = "Cannot unify rigid type variable " ++ var ++

116+ hint = "Cannot unify rigid type variable " ++ var' ++

121 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

117 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

122 \variables are not shared between a top-level and let-bound type annotations."

118 \variables are not shared between a top-level and let-bound type annotations."

123

119

@@ -136,10 +132,10 @@ actuallyUnify region variable1 variable2 = do

136 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

132 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

137 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

133 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

138

134

139− (Is Appendable, _, _, Just ctor)

135+ (Is Appendable, _, _, Just name)

140− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1

136+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1

141− (_, Is Appendable, Just ctor, _)

137+ (_, Is Appendable, Just name, _)

142− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2

138+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2

143 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

139 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

144 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

140 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

145

141

@@ -202,3 +198,36 @@ actuallyUnify region variable1 variable2 = do

202

198

203 _ -> TS.addError region Nothing variable1 variable2

199 _ -> TS.addError region Nothing variable1 variable2

204

200

201+combinedDescriptors :: Descriptor -> Descriptor

202+ -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)

203+combinedDescriptors desc1 desc2 =

204+ (name', flex', rank', alias')

205+ where

206+ rank' :: Int

207+ rank' = min (rank desc1) (rank desc2)

208+

209+ alias' :: Maybe Var.Canonical

210+ alias' = alias desc1 <|> alias desc2

211+

212+ name' :: Maybe Var.Canonical

213+ name' = case (name desc1, name desc2) of

214+ (Just name1, Just name2) ->

215+ case (flex desc1, flex desc2) of

216+ (_, Flexible) -> Just name1

217+ (Flexible, _) -> Just name2

218+ (Is Number, Is _) -> Just name1

219+ (Is _, Is Number) -> Just name2

220+ (Is _, Is _) -> Just name1

221+ (_, _) -> Nothing

222+ (Just name1, _) -> Just name1

223+ (_, Just name2) -> Just name2

224+ _ -> Nothing

225+

226+ flex' :: Flex

227+ flex' = case (flex desc1, flex desc2) of

228+ (f, Flexible) -> f

229+ (Flexible, f) -> f

230+ (Is Number, Is _) -> Is Number

231+ (Is _, Is Number) -> Is Number

232+ (Is super, Is _) -> Is super

233+ (_, _) -> Flexible

libraries/Basics.elm+20−8

@@ -46,7 +46,7 @@ which happen to be radians.

46@docs fst, snd

47

48# Higher-Order Helpers

49−@docs id, (<|), (|>), (.), always, flip, curry, uncurry

49+@docs id, always, (<|), (|>), (.), flip, curry, uncurry

50

51-}

52

@@ -58,25 +58,25 @@ radians t = t

58

59{-| Convert degrees to standard Elm angles (radians). -}

60degrees : Float -> Float

61−degrees d = d * Native.Basics.pi / 180

61+degrees = Native.Basics.degrees

62

63{-| Convert turns to standard Elm angles (radians).

64One turn is equal to 360°.

65-}

66turns : Float -> Float

67−turns r = 2 * Native.Basics.pi * r

67+turns = Native.Basics.turns

68

69{-| Start with polar coordinates (r,θ)

70and get out cartesian coordinates (x,y).

71-}

72fromPolar : (Float,Float) -> (Float,Float)

73−fromPolar (r,t) = (r * Native.Basics.cos t, r * Native.Basics.sin t)

73+fromPolar = Native.Basics.fromPolar

74

75{-| Start with cartesian coordinates (x,y)

76and get out polar coordinates (r,θ).

77-}

78toPolar : (Float,Float) -> (Float,Float)

79−toPolar (x,y) = (Native.Basics.sqrt (x^2 + y^2), Native.Basics.atan2 y x)

79+toPolar = Native.Basics.toPolar

80

81(+) : number -> number -> number

82(+) = Native.Basics.add

@@ -150,7 +150,7 @@ atan2 : Float -> Float -> Float

150atan2 = Native.Basics.atan2

151

152{-| Take the square root of a number. -}

153−sqrt : number -> number

153+sqrt : Float -> Float

154sqrt = Native.Basics.sqrt

155

156{-| Take the absolute value of a number. -}

@@ -158,7 +158,7 @@ abs : number -> number

158abs = Native.Basics.abs

159

160{-| Calculate the logarithm of a number with a given base: `logBase 10 100 == 2` -}

161−logBase : number -> number -> number

161+logBase : Float -> Float -> Float

162logBase = Native.Basics.logBase

163

164{-| Clamps a number within a given range. With the expression

@@ -301,7 +301,19 @@ isInfinite = Native.Basics.isInfinite

301

302-- Function Helpers

303

304−{-| Function composition: `(f . g == (\\x -> f (g x)))` -}

304+{-| Function composition. For example, the following code checks if the square

305+root of a number is odd:

306+

307+ not . isEven . sqrt

308+

309+You can think of this operator as equivalent to the following:

310+

311+ (f . g) == (\x -> f (g x))

312+

313+So our example is expanding things out to this:

314+

315+ \number -> not (isEven (sqrt number))

316+-}

305(.) : (b -> c) -> (a -> b) -> (a -> c)

317(.) : (b -> c) -> (a -> b) -> (a -> c)

306(.) f g x = f (g x)

318(.) f g x = f (g x)

307

319

libraries/Color.elm+3−3

@@ -60,7 +60,7 @@ with an alpha component for transparency.

60-}

61hsla : Float -> Float -> Float -> Float -> Color

62hsla hue saturation lightness alpha =

63− HSLA (hue - toFloat (floor (hue / (2*pi)))) saturation lightness alpha

63+ HSLA (hue - turns (toFloat (floor (hue / (2*pi))))) saturation lightness alpha

64

65{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives

66you access to colors more like a color wheel, where all hues are aranged in a

@@ -97,7 +97,7 @@ complement color =

97 RGBA r g b a -> let (h,s,l) = rgbToHsl r g b

98 in hsla (h + degrees 180) s l a

99

100−{-| Extract the the components of a color in the HSL format.

100+{-| Extract the components of a color in the HSL format.

101-}

102toHsl : Color -> { hue:Float, saturation:Float, lightness:Float, alpha:Float }

103toHsl color =

@@ -107,7 +107,7 @@ toHsl color =

107 let (h,s,l) = rgbToHsl r g b

108 in { hue=h, saturation=s, lightness=l, alpha=a }

109

110−{-| Extract the the components of a color in the RGB format.

110+{-| Extract the components of a color in the RGB format.

111-}

112toRgb : Color -> { red:Int, green:Int, blue:Int, alpha:Float }

113toRgb color =

libraries/Debug.elm+32−2

@@ -2,11 +2,16 @@ module Debug where

2{-| This library is for investigating bugs or performance problems. It should

3*not* be used in production code.

4

5−@docs log, trace

5+# Console Debugging

6+@docs log, crash

7+

8+# Time-Travel Debugging

9+@docs watch, watchSummary, trace

6-}

10-}

7

11

8import Graphics.Element (Element)

12import Graphics.Element (Element)

9import Native.Debug

13import Native.Debug

14+import Native.Error

10

15

11{-| Log a tagged value on the developer console, and then return the value.

16{-| Log a tagged value on the developer console, and then return the value.

12

17

@@ -19,6 +24,32 @@ investigating bugs or performance problems.

19log : String -> a -> a

24log : String -> a -> a

20log = Native.Debug.log

25log = Native.Debug.log

21

26

27+{-| Crash the program with an error message. This is an uncatchable error,

28+intended for code that is soon-to-be-implemented. For example, if you are

29+working with a large ADT and have partially completed a case expression, it may

30+make sense to do this:

31+

32+ data Entity = Ship | Fish | Captain | Seagull

33+

34+ drawEntity entity =

35+ case entity of

36+ Ship -> ...

37+ Fish -> ...

38+ _ -> Debug.crash ("drawEntity not implemented for " ++ show entity ++ " yet!")

39+

40+Note that incomplete pattern matches are *very* bad practice! They are one of

41+the very few ways to crash an Elm program, and they are completely avoidable.

42+Production code should not have incomplete pattern matches!

43+

44+**Use this if** you want to do some testing while you are partway through

45+writing a function.

46+

47+**Do not use this if** you want to do some typical try-catch exception handling.

48+Use the `Maybe` or `Either` libraries instead.

49+-}

50+crash : String -> a

51+crash = Native.Error.raise

52+

22{-| Watch a particular value in the reactive debugger.

53{-| Watch a particular value in the reactive debugger.

23-}

54-}

24watch : String -> a -> a

55watch : String -> a -> a

@@ -33,4 +64,3 @@ watchSummary = Native.Debug.watchSummary

33-}

64-}

34trace : String -> Element -> Element

65trace : String -> Element -> Element

35trace = Native.Debug.tracePath

66trace = Native.Debug.tracePath

36−

libraries/Dict.elm+2−1

@@ -37,6 +37,7 @@ import Basics (..)

37import Maybe (..)

38import Native.Error

39import List

40+import List ((::))

40import Native.Utils

41import Native.Utils

41

42

42-- BBlack and NBlack should only be used during the deletion

43-- BBlack and NBlack should only be used during the deletion

@@ -248,7 +249,7 @@ reportRemBug msg c lgot rgot =

248 lgot,

249 lgot,

249 " ",

250 " ",

250 rgot,

251 rgot,

251− "\nPlease report this bug to https://github.com/evancz/Elm/issues"

252+ "\nPlease report this bug to https://github.com/elm-lang/Elm/issues"

252 ]

253 ]

253

254

254-- Remove the top node from the tree, may leave behind BBlacks

255-- Remove the top node from the tree, may leave behind BBlacks

libraries/Either.elm+2−1

@@ -14,8 +14,9 @@ module Either where

14-}

15

16import List

17+import List ((::))

17

18

18−{-| Represents any data may take two forms. For example, a user ID may be

19+{-| Represents any data that can take two forms. For example, a user ID may be

19either an `Int` or a `String`.

20either an `Int` or a `String`.

20

21

21This can also be used for error handling `(Either String a)` where

22This can also be used for error handling `(Either String a)` where

libraries/Graphics/Collage.elm+1−1

@@ -32,7 +32,7 @@ it as a single unit.

32

33import Basics (..)

34import List

35−import Either (Either, Left, Right)

35+import Either (Either(Left, Right))

36import Transform2D (Transform2D, identity)

37import Native.Graphics.Collage

38import Graphics.Element (Element)

libraries/Graphics/Element.elm+1−1

@@ -41,7 +41,7 @@ import Basics (..)

41import Native.Utils

42import List as List

43import Color (..)

44−import Maybe (Maybe, Just, Nothing)

44+import Maybe ( Maybe(..) )

45

46type Properties = {

47 id : Int,

libraries/Graphics/Input/Field.elm+4−4

@@ -33,8 +33,8 @@ edges all have width 1:

33uniformly : Int -> Dimensions

34uniformly n = Dimensions n n n n

35

36−{-| For setting dimensions of a fields padding or border. The left, right, top,

36+{-| For setting dimensions of a field's padding or outline. The left, right,

37−and bottom may all have different sizes. The following example creates

37+top, and bottom may all have different sizes. The following example creates

38dimensions such that the left and right are twice as wide as the top and bottom:

39

40 myDimensions : Int -> Dimensions

@@ -69,8 +69,8 @@ noHighlight : Highlight

69noHighlight = Highlight Color.blue 0

70

71{-| Describe the style of a text box. `style` describes the style of the text

72−itself using [`Text.Style`](/Text#Style). `outline` describes the glowing blue

72+itself using [`Text.Style`](/Text#Style). `highlight` describes the glowing blue

73−outline that shows up when the field has focus. `outline` describes the line

73+highlight that shows up when the field has focus. `outline` describes the line

74surrounding the text field, and `padding` adds whitespace between the `outline`

75and the text.

76

libraries/Keyboard.elm+15−8

@@ -8,7 +8,10 @@ module Keyboard where

8@docs arrows, wasd, directions

9

10# Specific Keys

11−@docs shift, enter, space, ctrl

11+The following signals are `True` when the particular key is pressed and `False`

12+otherwise.

13+

14+@docs enter, space, ctrl, shift, alt, meta

12

15

13# General Keypresses

16# General Keypresses

14@docs isDown, keysDown, lastPressed

17@docs isDown, keysDown, lastPressed

@@ -50,19 +53,23 @@ wasd = directions 87 83 65 68

50isDown : KeyCode -> Signal Bool

53isDown : KeyCode -> Signal Bool

51isDown = Native.Keyboard.isDown

54isDown = Native.Keyboard.isDown

52

55

53−{-| Whether the shift key is pressed. -}

56+alt : Signal Bool

57+alt = Native.Keyboard.alt

58+

59+ctrl : Signal Bool

60+ctrl = isDown 17

61+

62+{-| The meta key is the Windows key on Windows and the Command key on Mac.

63+-}

64+meta : Signal Bool

65+meta = Native.Keyboard.meta

66+

54shift : Signal Bool

67shift : Signal Bool

55shift = isDown 16

68shift = isDown 16

56

69

57−{-| Whether the control key is pressed. -}

58−ctrl : Signal Bool

59−ctrl = isDown 17

60−

61−{-| Whether the space key is pressed. -}

62space : Signal Bool

70space : Signal Bool

63space = isDown 32

71space = isDown 32

64

72

65−{-| Whether the enter key is pressed. -}

66enter : Signal Bool

73enter : Signal Bool

67enter = isDown 13

74enter = isDown 13

68

75

libraries/List.elm+32−11

@@ -10,16 +10,19 @@ list must have the same type.

10@docs head, tail, last, filter, take, drop

11

12# Putting Lists Together

13−@docs concat, concatMap, join, intersperse, zip, zipWith, repeat

13+@docs concat, join, intersperse, zip, zipWith, repeat

14

15# Taking Lists Apart

16@docs partition, unzip

17

18# Folds

19−@docs foldr, foldl, foldr1, foldl1, scanl, scanl1

19+@docs foldr, foldl

20+

21+# Special Maps

22+@docs filterMap, concatMap, indexedMap

20

23

21# Special Folds

24# Special Folds

22−@docs sum, product, maximum, minimum, all, any, and, or

25+@docs sum, product, maximum, minimum, all, any, foldr1, foldl1, scanl, scanl1

23

26

24# Sorting

27# Sorting

25@docs sort, sortBy, sortWith

28@docs sort, sortBy, sortWith

@@ -35,6 +38,7 @@ possibly should be approached another way.

35-}

38-}

36

39

37import Basics (..)

40import Basics (..)

41+import Maybe ( Maybe(Just,Nothing) )

38import Native.List

42import Native.List

39

43

40{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

44{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

@@ -81,6 +85,15 @@ isEmpty xs =

81map : (a -> b) -> [a] -> [b]

85map : (a -> b) -> [a] -> [b]

82map = Native.List.map

86map = Native.List.map

83

87

88+{-| Same as `map` but the function is also applied to the index of each

89+element (starting at zero).

90+

91+ indexedMap (,) ["Tom","Sue","Bob"] == [ (0,"Tom"), (1,"Sue"), (2,"Bob") ]

92+-}

93+indexedMap : (Int -> a -> b) -> [a] -> [b]

94+indexedMap f xs =

95+ zipWith f [ 0 .. length xs - 1 ] xs

96+

84{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

97{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

85foldl : (a -> b -> b) -> b -> [a] -> b

98foldl : (a -> b -> b) -> b -> [a] -> b

86foldl = Native.List.foldl

99foldl = Native.List.foldl

@@ -117,6 +130,22 @@ scanl1 = Native.List.scanl1

117filter : (a -> Bool) -> [a] -> [a]

130filter : (a -> Bool) -> [a] -> [a]

118filter = Native.List.filter

131filter = Native.List.filter

119

132

133+{-| Apply a function that may succeed to all values in the list, but only keep

134+the successes.

135+

136+ toInt : String -> Maybe Int

137+

138+ filterMap toInt ["3", "4.0", "5", "hats"] == [3,5]

139+-}

140+filterMap : (a -> Maybe b) -> [a] -> [b]

141+filterMap xs = Native.List.foldr maybeCons [] xs

142+

143+maybeCons : Maybe a -> [a] -> [a]

144+maybeCons mx xs =

145+ case mx of

146+ Just x -> x :: xs

147+ Nothing -> xs

148+

120{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

149{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

121length : [a] -> Int

150length : [a] -> Int

122length = Native.List.length

151length = Native.List.length

@@ -133,14 +162,6 @@ all = Native.List.all

133any : (a -> Bool) -> [a] -> Bool

162any : (a -> Bool) -> [a] -> Bool

134any = Native.List.any

163any = Native.List.any

135

164

136−{-| Check to see if all elements are True. -}

137−and : [Bool] -> Bool

138−and = foldl (&&) True

139−

140−{-| Check to see if any elements are True. -}

141−or : [Bool] -> Bool

142−or = foldl (||) False

143−

144{-| Concatenate a list of appendable things:

165{-| Concatenate a list of appendable things:

145

166

146 concat [[1,2],[3],[4,5]] == [1,2,3,4,5]

167 concat [[1,2],[3],[4,5]] == [1,2,3,4,5]

libraries/Maybe.elm+15−17

@@ -1,4 +1,4 @@

1−module Maybe where

1+module Maybe (Maybe(..), maybe, isJust, isNothing, map) where

2

3{-| Represents an optional value. Maybe it is there, maybe it is not.

4

@@ -8,12 +8,11 @@ module Maybe where

8# Taking Maybes apart

9@docs maybe, isJust, isNothing

10

11−# Maybes and Lists

11+# Map

12−@docs justs

12+@docs map

13-}

14

15import Basics (not, (.))

16−import List (foldr)

17

16

18{-| The Maybe datatype. Useful when a computation may or may not

17{-| The Maybe datatype. Useful when a computation may or may not

19result in a value (e.g. logarithm is defined only for positive

18result in a value (e.g. logarithm is defined only for positive

@@ -27,14 +26,12 @@ function to the associated value.

27

26

28 isPositive : Maybe Int -> Bool

27 isPositive : Maybe Int -> Bool

29 isPositive maybeInt = maybe False (\n -> n > 0) maybeInt

28 isPositive maybeInt = maybe False (\n -> n > 0) maybeInt

30−

31− map : (a -> b) -> Maybe a -> Maybe b

32− map f m = maybe Nothing (\x -> Just (f x)) m

33-}

29-}

34maybe : b -> (a -> b) -> Maybe a -> b

30maybe : b -> (a -> b) -> Maybe a -> b

35−maybe b f m = case m of

31+maybe b f m =

36− Just v -> f v

32+ case m of

37− Nothing -> b

33+ Just v -> f v

34+ Nothing -> b

38

35

39{-| Check if a maybe happens to be a `Just`.

36{-| Check if a maybe happens to be a `Just`.

40

37

@@ -54,12 +51,13 @@ isJust = maybe False (\_ -> True)

54isNothing : Maybe a -> Bool

51isNothing : Maybe a -> Bool

55isNothing = not . isJust

52isNothing = not . isJust

56

53

57−cons : Maybe a -> [a] -> [a]

54+{-| Transform the contents of a `Maybe` with a given function:

58−cons mx xs = maybe xs (\x -> x :: xs) mx

59−

60−{-| Filters out Nothings and extracts the remaining values.

61

55

62− justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]

56+ map sqrt (Just 9) == Just 3

57+ map sqrt Nothing == Nothing

63-}

58-}

64−justs : [Maybe a] -> [a]

59+map : (a -> b) -> Maybe a -> Maybe b

65−justs = foldr cons []

60+map f maybe =

61+ case maybe of

62+ Just v -> Just (f v)

63+ Nothing -> Nothing

libraries/Native/Array.js+21−7

@@ -255,15 +255,27 @@ Elm.Native.Array.make = function(elm) {

255 }

256

257 function foldl(f, b, a) {

258− for (var i = 0; i < a.table.length; i++) {

258+ if (a.height == 0) {

259− b = A2(f, a.height == 0 ? a.table[i] : foldl(f, b, a.table[i]), b);

259+ for (var i = 0; i < a.table.length; i++) {

260+ b = A2(f, a.table[i], b);

261+ }

262+ } else {

263+ for (var i = 0; i < a.table.length; i++) {

264+ b = foldl(f, b, a.table[i]);

265+ }

260 }

266 }

261 return b;

267 return b;

262 }

268 }

263

269

264 function foldr(f, b, a) {

270 function foldr(f, b, a) {

265− for (var i = a.table.length; i--; ) {

271+ if (a.height == 0) {

266− b = A2(f, a.height == 0 ? a.table[i] : foldr(f, b, a.table[i]), b);

272+ for (var i = a.table.length; i--; ) {

273+ b = A2(f, a.table[i], b);

274+ }

275+ } else {

276+ for (var i = a.table.length; i--; ) {

277+ b = foldl(f, b, a.table[i]);

278+ }

267 }

279 }

268 return b;

280 return b;

269 }

281 }

@@ -345,9 +357,11 @@ Elm.Native.Array.make = function(elm) {

345 // TODO: Add support for appending trees of different sizes. Current

357 // TODO: Add support for appending trees of different sizes. Current

346 // behavior will just rise the lower tree and then append them.

358 // behavior will just rise the lower tree and then append them.

347 function append(a,b) {

359 function append(a,b) {

348− if (b.height > a.height) { return append(parentise(a, b.height), b); }

360+ if (a.table.length == 0) return b;

349− if (a.height > b.height) { return append(a, parentise(b, a.height)); }

361+ if (b.table.length == 0) return a;

350− if (a.height == 0) { return append(parentise(a, 1), parentise(b, 1)); }

362+ if (b.height > a.height) return append(parentise(a, b.height), b);

363+ if (a.height > b.height) return append(a, parentise(b, a.height));

364+ if (a.height == 0) return append(parentise(a, 1), parentise(b, 1));

351

365

352 var c = append_(a, b);

366 var c = append_(a, b);

353 if (c[1].table.length > 0) {

367 if (c[1].table.length > 0) {

libraries/Native/Basics.js+22

@@ -23,6 +23,23 @@ Elm.Native.Basics.make = function(elm) {

23

24 function truncate(n) { return n|0; }

25

26+ function degrees(d) {

27+ return d * Math.PI / 180;

28+ }

29+ function turns(t) {

30+ return 2 * Math.PI * t;

31+ }

32+ function fromPolar(point) {

33+ var r = point._0;

34+ var t = point._1;

35+ return Utils.Tuple2(r * Math.cos(t), r * Math.sin(t));

36+ }

37+ function toPolar(point) {

38+ var x = point._0;

39+ var y = point._1;

40+ return Utils.Tuple2(Math.sqrt(x * x + y * y), Math.atan2(y,x));

41+ }

42+

26 var basics = {

43 var basics = {

27 div:F2(div),

44 div:F2(div),

28 rem:F2(rem),

45 rem:F2(rem),

@@ -38,6 +55,11 @@ Elm.Native.Basics.make = function(elm) {

38 atan:Math.atan,

55 atan:Math.atan,

39 atan2:F2(Math.atan2),

56 atan2:F2(Math.atan2),

40

57

58+ degrees: degrees,

59+ turns: turns,

60+ fromPolar: fromPolar,

61+ toPolar: toPolar,

62+

41 sqrt:Math.sqrt,

63 sqrt:Math.sqrt,

42 abs:abs,

64 abs:abs,

43 logBase:F2(logBase),

65 logBase:F2(logBase),

libraries/Native/Char.js+6−4

@@ -4,6 +4,8 @@ Elm.Native.Char.make = function(elm) {

4 elm.Native.Char = elm.Native.Char || {};

5 if (elm.Native.Char.values) return elm.Native.Char.values;

6

7+ var Utils = Elm.Native.Utils.make(elm);

8+

7 function isBetween(lo,hi) { return function(chr) {

9 function isBetween(lo,hi) { return function(chr) {

8 var c = chr.charCodeAt(0);

10 var c = chr.charCodeAt(0);

9 return lo <= c && c <= hi;

11 return lo <= c && c <= hi;

@@ -16,10 +18,10 @@ Elm.Native.Char.make = function(elm) {

16 return elm.Native.Char.values = {

18 return elm.Native.Char.values = {

17 fromCode : function(c) { return String.fromCharCode(c); },

19 fromCode : function(c) { return String.fromCharCode(c); },

18 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

20 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

19− toUpper : function(c) { return c.toUpperCase(); },

21+ toUpper : function(c) { return Utils.chr(c.toUpperCase()); },

20− toLower : function(c) { return c.toLowerCase(); },

22+ toLower : function(c) { return Utils.chr(c.toLowerCase()); },

21− toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

23+ toLocaleUpper : function(c) { return Utils.chr(c.toLocaleUpperCase()); },

22− toLocaleLower : function(c) { return c.toLocaleLowerCase(); },

24+ toLocaleLower : function(c) { return Utils.chr(c.toLocaleLowerCase()); },

23 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

25 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

24 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

26 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

25 isDigit : isDigit,

27 isDigit : isDigit,

libraries/Native/Graphics/Input.js+84−52

@@ -21,46 +21,67 @@ Elm.Native.Graphics.Input.make = function(elm) {

21 return { _:{}, signal:signal, handle:signal };

22 }

23

24− function renderDropDown(signal, values) {

24+ function renderDropDown(model) {

25− return function(_) {

25+ var drop = newNode('select');

26− var entries = List.toArray(values);

26+ drop.style.border = '0 solid';

27−

27+ drop.style.pointerEvents = 'auto';

28− var drop = newNode('select');

28+ drop.style.display = 'block';

29− drop.style.border = '0 solid';

29+

30− drop.style.pointerEvents = 'auto';

30+ drop.elm_signal = model.signal;

31− for (var i = 0; i < entries.length; ++i) {

31+ drop.elm_values = List.toArray(model.values);

32− var option = newNode('option');

32+ var values = drop.elm_values;

33− var name = entries[i]._0;

33+

34− option.value = name;

34+ for (var i = 0; i < values.length; ++i) {

35− option.innerHTML = name;

35+ var option = newNode('option');

36− drop.appendChild(option);

36+ var name = values[i]._0;

37− }

37+ option.value = name;

38− drop.addEventListener('change', function() {

38+ option.innerHTML = name;

39− elm.notify(signal.id, entries[drop.selectedIndex]._1);

39+ drop.appendChild(option);

40− });

40+ }

41−

41+ drop.addEventListener('change', function() {

42− var t = drop.cloneNode(true);

42+ elm.notify(drop.elm_signal.id, drop.elm_values[drop.selectedIndex]._1);

43− t.style.visibility = "hidden";

43+ });

44

45− elm.node.appendChild(t);

45+ return drop;

46− var style = window.getComputedStyle(t, null);

47− var w = Math.ceil(style.getPropertyValue("width").slice(0,-2) - 0);

48− var h = Math.ceil(style.getPropertyValue("height").slice(0,-2) - 0);

49− elm.node.removeChild(t);

50− return drop;

51− };

52 }

46 }

53

47

54 function updateDropDown(node, oldModel, newModel) {

48 function updateDropDown(node, oldModel, newModel) {

49+ node.elm_signal = newModel.signal;

50+ node.elm_values = List.toArray(newModel.values);

51+

52+ var values = node.elm_values;

53+ var kids = node.childNodes;

54+ var kidsLength = kids.length;

55+

56+ var i = 0;

57+ for (; i < kidsLength && i < values.length; ++i) {

58+ var option = kids[i];

59+ var name = values[i]._0;

60+ option.value = name;

61+ option.innerHTML = name;

62+ }

63+ for (; i < kidsLength; ++i) {

64+ node.removeChild(node.lastChild);

65+ }

66+ for (; i < values.length; ++i) {

67+ var option = newNode('option');

68+ var name = values[i]._0;

69+ option.value = name;

70+ option.innerHTML = name;

71+ node.appendChild(option);

72+ }

55 }

73 }

56

74

57 function dropDown(signal, values) {

75 function dropDown(signal, values) {

58 return A3(newElement, 100, 24, {

76 return A3(newElement, 100, 24, {

59 ctor: 'Custom',

77 ctor: 'Custom',

60 type: 'DropDown',

78 type: 'DropDown',

61− render: renderDropDown(signal,values),

79+ render: renderDropDown,

62 update: updateDropDown,

80 update: updateDropDown,

63− model: {}

81+ model: {

82+ signal: signal,

83+ values: values

84+ }

64 });

85 });

65 }

86 }

66

87

@@ -105,52 +126,63 @@ Elm.Native.Graphics.Input.make = function(elm) {

105 btn.elm_hover = Render.render(model.hover);

126 btn.elm_hover = Render.render(model.hover);

106 btn.elm_down = Render.render(model.down);

127 btn.elm_down = Render.render(model.down);

107

128

108− function replace(node) {

129+ btn.elm_up.style.display = 'block';

109− if (node !== btn.firstChild) {

130+ btn.elm_hover.style.display = 'none';

110− btn.replaceChild(node, btn.firstChild);

131+ btn.elm_down.style.display = 'none';

111− }

132+

133+ btn.appendChild(btn.elm_up);

134+ btn.appendChild(btn.elm_hover);

135+ btn.appendChild(btn.elm_down);

136+

137+ function swap(visibleNode, hiddenNode1, hiddenNode2) {

138+ visibleNode.style.display = 'block';

139+ hiddenNode1.style.display = 'none';

140+ hiddenNode2.style.display = 'none';

112 }

141 }

142+

113 var overCount = 0;

143 var overCount = 0;

114 function over(e) {

144 function over(e) {

115 if (overCount++ > 0) return;

145 if (overCount++ > 0) return;

116− replace(btn.elm_hover);

146+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

117 }

147 }

118 function out(e) {

148 function out(e) {

119 if (btn.contains(e.toElement || e.relatedTarget)) return;

149 if (btn.contains(e.toElement || e.relatedTarget)) return;

120 overCount = 0;

150 overCount = 0;

121− replace(btn.elm_up);

151+ swap(btn.elm_up, btn.elm_down, btn.elm_hover);

122 }

152 }

123 function up() {

153 function up() {

124− replace(btn.elm_hover);

154+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

125 elm.notify(btn.elm_signal.id, btn.elm_value);

155 elm.notify(btn.elm_signal.id, btn.elm_value);

126 }

156 }

127 function down() {

157 function down() {

128− replace(btn.elm_down);

158+ swap(btn.elm_down, btn.elm_hover, btn.elm_up);

129 }

159 }

160+

130 btn.addEventListener('mouseover', over);

161 btn.addEventListener('mouseover', over);

131 btn.addEventListener('mouseout' , out);

162 btn.addEventListener('mouseout' , out);

132 btn.addEventListener('mousedown', down);

163 btn.addEventListener('mousedown', down);

133 btn.addEventListener('mouseup' , up);

164 btn.addEventListener('mouseup' , up);

134

165

135− btn.appendChild(btn.elm_up);

136−

137 return btn;

166 return btn;

138 }

167 }

139

168

140 function updateCustomButton(node, oldModel, newModel) {

169 function updateCustomButton(node, oldModel, newModel) {

141− var signal = newModel.signal;

170+ node.elm_signal = newModel.signal;

142− node.elm_up.elm_signal = signal;

171+ node.elm_value = newModel.value;

143− node.elm_hover.elm_signal = signal;

172+

144− node.elm_down.elm_signal = signal;

173+ var kids = node.childNodes;

145−

174+ var styleUp = kids[0].style.display;

146− var value = newModel.value;

175+ var styleHover = kids[1].style.display;

147− node.elm_up.elm_value = value;

176+ var styleDown = kids[2].style.display;

148− node.elm_hover.elm_value = value;

177+

149− node.elm_down.elm_value = value;

178+ Render.update(kids[0], oldModel.up, newModel.up);

150−

179+ Render.update(kids[1], oldModel.hover, newModel.hover);

151− Render.update(node.elm_up, oldModel.up, newModel.up)

180+ Render.update(kids[2], oldModel.down, newModel.down);

152− Render.update(node.elm_hover, oldModel.hover, newModel.hover)

181+

153− Render.update(node.elm_down, oldModel.down, newModel.down)

182+ var kids = node.childNodes;

183+ kids[0].style.display = styleUp;

184+ kids[1].style.display = styleHover;

185+ kids[2].style.display = styleDown;

154 }

186 }

155

187

156 function max3(a,b,c) {

188 function max3(a,b,c) {

libraries/Native/Signal/Keyboard.js+138−107

@@ -1,120 +1,151 @@

1Elm.Native.Keyboard = {};

2Elm.Native.Keyboard.make = function(elm) {

3

4− elm.Native = elm.Native || {};

4+ elm.Native = elm.Native || {};

5− elm.Native.Keyboard = elm.Native.Keyboard || {};

5+ elm.Native.Keyboard = elm.Native.Keyboard || {};

6− if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

6+ if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7−

7+

8− // Duplicated from Native.Signal

8+ // Duplicated from Native.Signal

9− function send(node, timestep, changed) {

9+ function send(node, timestep, changed) {

10− var kids = node.kids;

10+ var kids = node.kids;

11− for (var i = kids.length; i--; ) {

11+ for (var i = kids.length; i--; ) {

12− kids[i].recv(timestep, changed, node.id);

12+ kids[i].recv(timestep, changed, node.id);

13+ }

14+ }

15+

16+ var Signal = Elm.Signal.make(elm);

17+ var NList = Elm.Native.List.make(elm);

18+ var Utils = Elm.Native.Utils.make(elm);

19+

20+ var downEvents = Signal.constant(null);

21+ var upEvents = Signal.constant(null);

22+ var blurEvents = Signal.constant(null);

23+

24+ elm.addListener([downEvents.id], document, 'keydown', function down(e) {

25+ elm.notify(downEvents.id, e);

26+ });

27+

28+ elm.addListener([upEvents.id], document, 'keyup', function up(e) {

29+ elm.notify(upEvents.id, e);

30+ });

31+

32+ elm.addListener([blurEvents.id], window, 'blur', function blur(e) {

33+ elm.notify(blurEvents.id, null);

34+ });

35+

36+ function state(alt, meta, keyCodes) {

37+ return {

38+ alt: alt,

39+ meta: meta,

40+ keyCodes: keyCodes

41+ };

13 }

42 }

14− }

43+ var emptyState = state(false, false, NList.Nil);

15−

44+

16− var Signal = Elm.Signal.make(elm);

45+ function KeyMerge(down, up, blur) {

17− var NList = Elm.Native.List.make(elm);

46+ var args = [down,up,blur];

18− var Utils = Elm.Native.Utils.make(elm);

47+ this.id = Utils.guid();

19−

48+ // Ignore starting values here

20− var NS = Elm.Native.Signal.make(elm);

49+ this.value = emptyState;

21− var downEvents = NS.input(0);

50+ this.kids = [];

22− var upEvents = NS.input(0);

51+

23− var blurEvents = NS.input(0);

52+ var n = args.length;

24−

53+ var count = 0;

25− elm.addListener([downEvents.id], document, 'keydown', function down(e) {

54+ var isChanged = false;

26− elm.notify(downEvents.id, e.keyCode);

55+

27− });

56+ this.recv = function(timestep, changed, parentID) {

28−

57+ ++count;

29− elm.addListener([upEvents.id], document, 'keyup', function up(e) {

58+ if (changed) {

30− elm.notify(upEvents.id, e.keyCode);

59+ // We know this a change must only be one of the following cases

31− });

60+ if (parentID === down.id && !A2(NList.member, down.value.keyCode, this.value.keyCodes)) {

32−

61+ isChanged = true;

33− elm.addListener([blurEvents.id], document, 'blur', function blur(e) {

62+ var v = down.value;

34− elm.notify(blurEvents.id, NList.Nil);

63+ var newCodes = NList.Cons(v.keyCode, this.value.keyCodes);

35− });

64+ this.value = state(v.altKey, v.metaKey, newCodes);

36−

65+ }

37− function KeyMerge(down, up, blur) {

66+ else if (parentID === up.id) {

38− this.nodeType = "merge";

67+ isChanged = true;

39−

68+ var v = up.value;

40− var args = [down,up,blur];

69+ var notEq = function(kc) { return kc !== v.keyCode };

41− this.id = Utils.guid();

70+ var newCodes = A2(NList.filter, notEq, this.value.keyCodes);

42− // Ignore starting values here

71+ this.value = state(v.altKey, v.metaKey, newCodes);

43− this.value = NList.Nil

72+ }

44− this.kids = [];

73+ else if (parentID === blur.id) {

45−

74+ isChanged = true;

46− var n = args.length;

75+ this.value = emptyState;

47− var count = 0;

76+ }

48− var isChanged = false;

77+ }

49−

78+ if (count == n) {

50− this.recv = function(timestep, changed, parentID) {

79+ send(this, timestep, isChanged);

51− ++count;

80+ isChanged = false;

52− if (changed) {

81+ count = 0;

53− // We know this a change must only be one of the following cases

82+ }

54− if (parentID === down.id && !(NList.member(down.value)(this.value))) {

83+ };

55− isChanged = true;

84+

56− this.value = NList.Cons(down.value, this.value);

85+ for (var i = n; i--; ) {

57− }

86+ args[i].kids.push(this);

58− if (parentID === up.id) {

87+ args[i].defaultNumberOfKids += 1;

59− isChanged = true;

60− var notEq = function(kc) { return kc !== up.value };

61− this.value = NList.filter(notEq)(this.value);

62− }

63− if (parentID === blur.id) {

64− isChanged = true;

65− this.value = NList.Nil;

66 }

88 }

67− }

89+ }

68− if (count == n) {

69− send(this, timestep, isChanged);

70− isChanged = false;

71− count = 0;

72− }

73− };

74

90

75− for (var i = n; i--; ) { args[i].kids.push(this); }

91+ var keyMerge = new KeyMerge(downEvents,upEvents,blurEvents);

76−

92+

77− }

93+ // select a part of a keyMerge and dropRepeats the result

78−

94+ function keySignal(f) {

79− var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));

95+ var signal = A2(Signal.lift, f, keyMerge);

80−

96+ // must set the default number of kids to make it possible to filter

81− function keySignal(f) {

97+ // these signals if they are not actually used.

82− var signal = A2(Signal.lift, f, keysDown);

98+ keyMerge.defaultNumberOfKids += 1;

83− // must set the default number of kids to make it possible to filter

99+ signal.defaultNumberOfKids = 1;

84− // these signals if they are not actually used.

100+ var filtered = Signal.dropRepeats(signal);

85− keysDown.defaultNumberOfKids += 1;

101+ filtered.defaultNumberOfKids = 0;

86− signal.defaultNumberOfKids = 1;

102+ return filtered;

87− var filtered = Signal.dropRepeats(signal)

103+ }

88− filtered.defaultNumberOfKids = 0;

104+

89− return filtered;

105+ // break keyMerge into parts

90− }

106+ var keysDown = keySignal(function getKeyCodes(v) {

91−

107+ return v.keyCodes;

92− function dir(up, down, left, right) {

108+ });

93− function f(ks) {

109+ var alt = keySignal(function getKeyCodes(v) {

94− var x = 0, y = 0;

110+ return v.alt;

95− while (ks.ctor === "::") {

111+ });

96− switch (ks._0) {

112+ var meta = keySignal(function getKeyCodes(v) {

97− case left : --x; break;

113+ return v.meta;

98− case right: ++x; break;

114+ });

99− case up : ++y; break;

115+

100− case down : --y; break;

116+ function dir(up, down, left, right) {

117+ function toDirections(state) {

118+ var keyCodes = state.keyCodes;

119+ var x = 0, y = 0;

120+ while (keyCodes.ctor === "::") {

121+ switch (keyCodes._0) {

122+ case left : --x; break;

123+ case right: ++x; break;

124+ case up : ++y; break;

125+ case down : --y; break;

126+ }

127+ keyCodes = keyCodes._1;

128+ }

129+ return { _:{}, x:x, y:y };

101 }

130 }

102− ks = ks._1;

131+ return keySignal(toDirections);

103− }

104− return { _:{}, x:x, y:y };

105 }

132 }

106− return keySignal(f);

107− }

108

133

109− function is(key) { return keySignal(NList.member(key)); }

134+ function is(key) {

135+ return keySignal(function(v) {

136+ return A2( NList.member, key, v.keyCodes );

137+ });

138+ }

110

139

111− var lastPressed = downEvents;

140+ var lastPressed = downEvents;

112

141

113− return elm.Native.Keyboard.values = {

142+ return elm.Native.Keyboard.values = {

114− isDown:is,

143+ isDown:is,

115− directions:F4(dir),

144+ alt: alt,

116− keysDown:keysDown,

145+ meta: meta,

117− lastPressed:lastPressed

146+ directions:F4(dir),

118− };

147+ keysDown:keysDown,

148+ lastPressed:lastPressed

149+ };

119

150

120};

151};

libraries/Native/Signal/WebSocket.js+1−1

@@ -9,7 +9,7 @@ Elm.Native.WebSocket.make = function(elm) {

9 var List = Elm.Native.List.make(elm);

10

11 function open(url, outgoing) {

12− var incoming = Signal.constant(List.Nil);

12+ var incoming = Signal.constant("");

13 var ws = new WebSocket(url);

14

15 var pending = [];

libraries/Signal.elm+1−1

@@ -30,7 +30,7 @@ the `Time` library.

30-}

31

32import Native.Signal

33−import List (foldr)

33+import List (foldr, (::))

34import Basics (fst, snd, not)

35

36data Signal a = Signal

libraries/String.elm+3−2

@@ -123,6 +123,7 @@ split = Native.String.split

123

124{-| Put many strings together with a given separator.

125

126+ join "a" ["H","w","ii","n"] == "Hawaiian"

126 join " " ["cat","dog","cow"] == "cat dog cow"

127 join " " ["cat","dog","cow"] == "cat dog cow"

127 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

128 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

128-}

129-}

@@ -204,7 +205,7 @@ trim = Native.String.trim

204trimLeft : String -> String

205trimLeft : String -> String

205trimLeft = Native.String.trimLeft

206trimLeft = Native.String.trimLeft

206

207

207−{-| Get rid of whitespace on the left of a string.

208+{-| Get rid of whitespace on the right of a string.

208

209

209 trimRight " hats \n" == " hats"

210 trimRight " hats \n" == " hats"

210-}

211-}

@@ -220,7 +221,7 @@ words = Native.String.words

220

221

221{-| Break a string into lines, splitting on newlines.

222{-| Break a string into lines, splitting on newlines.

222

223

223− lines "How are you?\nGood? == ["How are you?", "Good?"]

224+ lines "How are you?\nGood?" == ["How are you?", "Good?"]

224-}

225-}

225lines : String -> [String]

226lines : String -> [String]

226lines = Native.String.lines

227lines = Native.String.lines

libraries/Text.elm+2−2

@@ -34,7 +34,7 @@ import Basics (..)

34import String

35import Color (Color, black)

36import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

37−import Maybe (Maybe, Nothing)

37+import Maybe (Maybe(Nothing))

38import Native.Show

39import Native.Text

40

@@ -212,7 +212,7 @@ markdown = Native.Text.markdown

212{-| Convert anything to its textual representation and make it displayable in

213the browser:

214

215− asText value = text (monospace (show value))

215+ asText value = leftAligned (monospace (toText (show value)))

216

217Excellent for debugging.

218-}

libraries/Transform2D.elm+5−1

@@ -1,4 +1,8 @@

1−module Transform2D where

1+module Transform2D ( Transform2D

2+ , identity, matrix, multiply

3+ , rotation, translation

4+ , scale, scaleX, scaleY

5+ ) where

2{-| A library for performing [2D matrix transformations][affine].

6{-| A library for performing [2D matrix transformations][affine].

3It is used primarily with the `groupTransform` function from `Graphics.Collage` and

7It is used primarily with the `groupTransform` function from `Graphics.Collage` and

4allows you to do things like rotation, scaling, translation, shearing, and reflection.

8allows you to do things like rotation, scaling, translation, shearing, and reflection.

libraries/WebSocket.elm−1

@@ -8,7 +8,6 @@ change to make it more flexible.

8-}

9

10import Signal (Signal)

11−import Basics (String)

12import Native.WebSocket

11import Native.WebSocket

13

12

14{-| Create a web-socket. The first argument is the URL of the desired

13{-| Create a web-socket. The first argument is the URL of the desired

runtime/Init.js+3−2

@@ -63,7 +63,7 @@ function init(display, container, module, ports, moduleToReplace) {

63 throw new Error(

64 'The notify function has been called synchronously!\n' +

65 'This can lead to frames being dropped.\n' +

66− 'Definitely report this to <https://github.com/evancz/Elm/issues>\n');

66+ 'Definitely report this to <https://github.com/elm-lang/Elm/issues>\n');

67 }

68 updateInProgress = true;

69 var timestep = timer.now();

@@ -258,8 +258,9 @@ function initGraphics(elm, Module) {

258

259 // set up updates so that the DOM is adjusted as necessary.

260 var savedScene = currentScene;

261+ var previousDrawId = 0;

261 function domUpdate(newScene) {

262 function domUpdate(newScene) {

262− ElmRuntime.draw(function(_) {

263+ previousDrawId = ElmRuntime.draw(previousDrawId, function(_) {

263 Render.update(elm.node.firstChild, savedScene, newScene);

264 Render.update(elm.node.firstChild, savedScene, newScene);

264 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

265 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

265 savedScene = newScene;

266 savedScene = newScene;

runtime/Render/Element.js+75−61

@@ -7,40 +7,45 @@ var newElement = Utils.newElement, colorToCss = Utils.colorToCss,

7 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,

8 fromList = Utils.fromList, eq = Utils.eq;

9

10−function setProps(elem, e) {

10+function setProps(elem, node) {

11 var props = elem.props;

12+

12 var element = elem.element;

13 var element = elem.element;

13 var width = props.width - (element.adjustWidth || 0);

14 var width = props.width - (element.adjustWidth || 0);

14 var height = props.height - (element.adjustHeight || 0);

15 var height = props.height - (element.adjustHeight || 0);

15− e.style.width = (width |0) + 'px';

16+ node.style.width = (width |0) + 'px';

16− e.style.height = (height|0) + 'px';

17+ node.style.height = (height|0) + 'px';

18+

17 if (props.opacity !== 1) {

19 if (props.opacity !== 1) {

18− e.style.opacity = props.opacity;

20+ node.style.opacity = props.opacity;

19 }

21 }

22+

20 if (props.color.ctor === 'Just') {

23 if (props.color.ctor === 'Just') {

21− e.style.backgroundColor = colorToCss(props.color._0);

24+ node.style.backgroundColor = colorToCss(props.color._0);

22 }

25 }

23− if (props.tag !== '') { e.id = props.tag; }

26+

24− if (props.href !== '') {

27+ if (props.tag !== '') {

25− var a = newElement('a');

28+ node.id = props.tag;

26− a.href = props.href;

27− a.style.width = '100%';

28− a.style.height = '100%';

29− a.style.top = 0;

30− a.style.left = 0;

31− a.style.display = 'block';

32− a.style.position = 'absolute';

33− e.style.position = 'relative';

34− a.style.pointerEvents = 'auto';

35− e.appendChild(a);

36 }

29 }

30+

37 if (props.hover.ctor !== '_Tuple0') {

31 if (props.hover.ctor !== '_Tuple0') {

38− addHover(e, props.hover);

32+ addHover(node, props.hover);

39 }

33 }

34+

40 if (props.click.ctor !== '_Tuple0') {

35 if (props.click.ctor !== '_Tuple0') {

41− addClick(e, props.click);

36+ addClick(node, props.click);

42 }

37 }

43− return e;

38+

39+ if (props.href !== '') {

40+ var anchor = newElement('a');

41+ anchor.href = props.href;

42+ anchor.style.display = 'block';

43+ anchor.style.pointerEvents = 'auto';

44+ anchor.appendChild(node);

45+ node = anchor;

46+ }

47+

48+ return node;

44}

49}

45

50

46function addClick(e, handler) {

51function addClick(e, handler) {

@@ -354,61 +359,70 @@ function update(node, curr, next) {

354}

359}

355

360

356function updateProps(node, curr, next) {

361function updateProps(node, curr, next) {

357− var props = next.props;

362+ var nextProps = next.props;

358− var currP = curr.props;

363+ var currProps = curr.props;

359− var e = node;

364+

360 var element = next.element;

365 var element = next.element;

361− var width = props.width - (element.adjustWidth || 0);

366+ var width = nextProps.width - (element.adjustWidth || 0);

362− var height = props.height - (element.adjustHeight || 0);

367+ var height = nextProps.height - (element.adjustHeight || 0);

363− if (width !== currP.width) {

368+ if (width !== currProps.width) {

364− e.style.width = (width|0) + 'px';

369+ node.style.width = (width|0) + 'px';

370+ }

371+ if (height !== currProps.height) {

372+ node.style.height = (height|0) + 'px';

365 }

373 }

366− if (height !== currP.height) {

374+

367− e.style.height = (height|0) + 'px';

375+ if (nextProps.opacity !== currProps.opacity) {

376+ node.style.opacity = nextProps.opacity;

368 }

377 }

369− if (props.opacity !== currP.opacity) {

378+

370− e.style.opacity = props.opacity;

379+ var nextColor = nextProps.color.ctor === 'Just'

380+ ? colorToCss(nextProps.color._0)

381+ : 'transparent';

382+ if (node.style.backgroundColor !== nextColor) {

383+ node.style.backgroundColor = nextColor;

371 }

384 }

372− var nextColor = (props.color.ctor === 'Just' ?

385+

373− colorToCss(props.color._0) : '');

386+ if (nextProps.tag !== currProps.tag) {

374− if (e.style.backgroundColor !== nextColor) {

387+ node.id = nextProps.tag;

375− e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);

376 }

388 }

377− if (props.tag !== currP.tag) { e.id = props.tag; }

389+

378− if (props.href !== currP.href) {

390+ if (nextProps.href !== currProps.href) {

379− if (currP.href === '') {

391+ if (currProps.href === '') {

380− var a = newElement('a');

392+ // add a surrounding href

381− a.href = props.href;

393+ var anchor = newElement('a');

382− a.style.width = '100%';

394+ anchor.href = nextProps.href;

383− a.style.height = '100%';

395+ anchor.style.display = 'block';

384− a.style.top = 0;

396+ anchor.style.pointerEvents = 'auto';

385− a.style.left = 0;

397+

386− a.style.display = 'block';

398+ node.parentNode.replaceChild(anchor, node);

387− a.style.position = 'absolute';

399+ anchor.appendChild(node);

388− e.style.position = 'relative';

400+ } else if (nextProps.href === '') {

389− a.style.pointerEvents = 'auto';

401+ // remove the surrounding href

390− e.appendChild(a);

402+ var anchor = node.parentNode;

403+ anchor.parentNode.replaceChild(node, anchor);

391 } else {

404 } else {

392− node.lastNode.href = props.href;

405+ // just update the link

406+ node.parentNode.href = nextProps.href;

393 }

407 }

394 }

408 }

395

409

396 // update hover handlers

410 // update hover handlers

397− if (props.hover.ctor === '_Tuple0') {

411+ if (nextProps.hover.ctor === '_Tuple0') {

398− removeHover(e);

412+ removeHover(node);

399− } else if (e.elm_hover_handler) {

413+ } else if (node.elm_hover_handler) {

400− e.elm_hover_handler = props.hover;

414+ node.elm_hover_handler = nextProps.hover;

401 } else {

415 } else {

402− addHover(e, props.hover);

416+ addHover(node, nextProps.hover);

403 }

417 }

404

418

405 // update click handlers

419 // update click handlers

406− if (props.click.ctor === '_Tuple0') {

420+ if (nextProps.click.ctor === '_Tuple0') {

407− removeClick(e);

421+ removeClick(node);

408− } else if (e.elm_click_handler) {

422+ } else if (node.elm_click_handler) {

409− e.elm_click_handler = props.click;

423+ node.elm_click_handler = nextProps.click;

410 } else {

424 } else {

411− addClick(e, props.click);

425+ addClick(node, nextProps.click);

412 }

426 }

413}

427}

414

428

runtime/Utils.js+14−6

@@ -32,7 +32,13 @@ ElmRuntime.filterDeadInputs = function(inputs) {

32 return temp;

33};

34

35−// define the draw function

35+// define function for drawing efficiently

36+//

37+// draw : RequestID -> (() -> ()) -> RequestID

38+//

39+// Takes a "RequestID" allowing you to cancel old requests if possible.

40+// Returns a "RequestID" so you can refer to past requests.

41+//

36var vendors = ['ms', 'moz', 'webkit', 'o'];

42var vendors = ['ms', 'moz', 'webkit', 'o'];

37var win = typeof window !== 'undefined' ? window : {};

43var win = typeof window !== 'undefined' ? window : {};

38for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

44for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

@@ -42,13 +48,15 @@ for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

42}

48}

43

49

44if (win.requestAnimationFrame && win.cancelAnimationFrame) {

50if (win.requestAnimationFrame && win.cancelAnimationFrame) {

45− var previous = 0;

51+ ElmRuntime.draw = function(previousRequestID, callback) {

46− ElmRuntime.draw = function(callback) {

52+ win.cancelAnimationFrame(previousRequestID);

47− win.cancelAnimationFrame(previous);

53+ return win.requestAnimationFrame(callback);

48− previous = win.requestAnimationFrame(callback);

49 };

54 };

50} else {

55} else {

51− ElmRuntime.draw = function(callback) { callback(); };

56+ ElmRuntime.draw = function(previousRequestID, callback) {

57+ callback();

58+ return previousRequestID;

59+ };

52}

60}

53

61

54}());

62}());

tests/compiler/Tests/Compiler.hs+27−23

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

1−module Tests.Compiler (compilerTests)

1+module Tests.Compiler (compilerTests) where

2− where

3

2

4import Data.Functor ((<$>))

3import Data.Functor ((<$>))

5import Data.Traversable (traverse)

4import Data.Traversable (traverse)

@@ -13,31 +12,36 @@ import Text.Parsec (ParseError)

13import Elm.Internal.Utils as Elm

12import Elm.Internal.Utils as Elm

14

13

15compilerTests :: Test

14compilerTests :: Test

16−compilerTests = buildTest $ do

15+compilerTests =

17− goods <- mkTests goodCompile =<< getElms "good"

16+ buildTest $ do

18− bads <- mkTests badCompile =<< getElms "bad"

17+ goods <- mkTests goodCompile =<< getElms "good"

19− return $ testGroup "Compile Tests"

18+ bads <- mkTests badCompile =<< getElms "bad"

20− [

19+ return $ testGroup "Compile Tests"

21− testGroup "Good Tests" goods

20+ [ testGroup "Good Tests" goods

22− , testGroup "Bad Tests" bads

21+ , testGroup "Bad Tests" bads

23− ]

22+ ]

24−

23+ where

25− where getElms :: FilePath -> IO [FilePath]

24+ getElms :: FilePath -> IO [FilePath]

26− getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

25+ getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

27−

26+

28− mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

27+ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

29− mkTests h = traverse setupTest

28+ mkTests h = traverse setupTest

30− where setupTest f = testCase f . mkCompileTest h <$> readFile f

29+ where setupTest f = testCase f . mkCompileTest h <$> readFile f

31−

30+

32− testsDir = "tests" </> "test-files"

31+ testsDir :: FilePath

32+ testsDir = "tests" </> "compiler" </> "test-files"

33

34goodCompile :: Either String String -> Assertion

35−goodCompile (Left err) = assertFailure err

35+goodCompile result =

36−goodCompile (Right _) = assertBool "" True

36+ case result of

37+ Left err -> assertFailure err

38+ Right _ -> assertBool "" True

37

39

38badCompile :: Either String String -> Assertion

40badCompile :: Either String String -> Assertion

39−badCompile (Left _) = assertBool "" True

41+badCompile result =

40−badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

42+ case result of

43+ Left _ -> assertBool "" True

44+ Right _ -> assertFailure "Compilation succeeded but should have failed"

41

45

42mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

46mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

43 -> String -- ^ File Contents

47 -> String -- ^ File Contents

tests/compiler/Tests/Property.hs+23−22

@@ -9,11 +9,12 @@ import Test.QuickCheck

9import Text.Parsec.Combinator (eof)

10import Text.PrettyPrint as P

11

12−import SourceSyntax.Literal as Lit

12+import AST.Literal as Lit

13−import qualified SourceSyntax.Pattern as P

13+import qualified AST.Pattern as P

14−import SourceSyntax.PrettyPrint (Pretty, pretty)

14+import qualified AST.Variable as V

15−import Parse.Helpers (IParser, iParse)

15+import AST.PrettyPrint (Pretty, pretty)

16−import Parse.Literal (literal)

16+import Parse.Helpers (IParser, iParse)

17+import Parse.Literal (literal)

17import qualified Parse.Pattern as Pat (expr)

18import qualified Parse.Pattern as Pat (expr)

18import qualified Parse.Type as Type (expr)

19import qualified Parse.Type as Type (expr)

19import Tests.Property.Arbitrary

20import Tests.Property.Arbitrary

@@ -21,8 +22,7 @@ import Tests.Property.Arbitrary

21propertyTests :: Test

22propertyTests :: Test

22propertyTests =

23propertyTests =

23 testGroup "Parse/Print Agreement Tests"

24 testGroup "Parse/Print Agreement Tests"

24− [

25+ [ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

25− testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

26 , testProperty "Literal test" $ prop_parse_print literal

27 , testProperty "Pattern test" $ prop_parse_print Pat.expr

28 , testProperty "Type test" $ prop_parse_print Type.expr

@@ -31,21 +31,22 @@ propertyTests =

31 where

32 -- This test was autogenerated from the Pattern test and should be

33 -- left in all its ugly glory.

34− longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

34+ longPat = P.Data (V.Raw "I")

35− , P.Record

35+ [ P.Literal (Lit.Chr '+')

36− [ "q7yclkcm7k_ikstrczv_"

36+ , P.Record

37− , "wQRv6gKsvvkjw4b5F"

37+ [ "q7yclkcm7k_ikstrczv_"

38− ,"c9'eFfhk9FTvsMnwF_D"

38+ , "wQRv6gKsvvkjw4b5F"

39− ,"yqxhEkHvRFwZ"

39+ ,"c9'eFfhk9FTvsMnwF_D"

40− ,"o"

40+ ,"yqxhEkHvRFwZ"

41− ,"nbUlCn3y3NnkVoxhW"

41+ ,"o"

42− ,"iJ0MNy3KZ_lrs"

42+ ,"nbUlCn3y3NnkVoxhW"

43− ,"ug"

43+ ,"iJ0MNy3KZ_lrs"

44− ,"sHHsX"

44+ ,"ug"

45− ,"mRKs9d"

45+ ,"sHHsX"

46− ,"o2KiCX5'ZRzHJfRi8" ]

46+ ,"mRKs9d"

47− , P.Var "su'BrrbPUK6I33Eq"

47+ ,"o2KiCX5'ZRzHJfRi8" ]

48− ]

48+ , P.Var "su'BrrbPUK6I33Eq"

49+ ]

49

50

50prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

51prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

51prop_parse_print p x =

52prop_parse_print p x =

tests/compiler/Tests/Property/Arbitrary.hs+21−12

@@ -8,9 +8,14 @@ import Test.QuickCheck.Gen

8import qualified Data.Set as Set

9import qualified Parse.Helpers (reserveds)

10

11−import qualified SourceSyntax.Literal as L

11+import qualified AST.Literal as L

12−import qualified SourceSyntax.Pattern as P

12+import qualified AST.Pattern as P

13−import qualified SourceSyntax.Type as T

13+import qualified AST.Type as T

14+import qualified AST.Variable as V

15+

16+instance Arbitrary V.Raw where

17+ arbitrary = V.Raw <$> capVar

18+ shrink (V.Raw v) = V.Raw <$> shrink v

14

19

15instance Arbitrary L.Literal where

20instance Arbitrary L.Literal where

16 arbitrary =

21 arbitrary =

@@ -41,10 +46,10 @@ genVector n generator = do

41 let m = n `div` (len + 1)

46 let m = n `div` (len + 1)

42 vectorOf len $ generator m

47 vectorOf len $ generator m

43

48

44−instance Arbitrary P.Pattern where

49+instance Arbitrary v => Arbitrary (P.Pattern v) where

45 arbitrary = sized pat

50 arbitrary = sized pat

46 where

51 where

47− pat :: Int -> Gen P.Pattern

52+ pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)

48 pat n =

53 pat n =

49 oneof

54 oneof

50 [ pure P.Anything

55 [ pure P.Anything

@@ -52,7 +57,7 @@ instance Arbitrary P.Pattern where

52 , P.Record <$> (listOf1 lowVar)

57 , P.Record <$> (listOf1 lowVar)

53 , P.Literal <$> arbitrary

58 , P.Literal <$> arbitrary

54 , P.Alias <$> lowVar <*> pat (n-1)

59 , P.Alias <$> lowVar <*> pat (n-1)

55− , P.Data <$> capVar <*> genVector n pat

60+ , P.Data <$> arbitrary <*> genVector n pat

56 ]

61 ]

57

62

58 shrink pat =

63 shrink pat =

@@ -61,7 +66,7 @@ instance Arbitrary P.Pattern where

61 P.Var v -> P.Var <$> shrinkWHead v

66 P.Var v -> P.Var <$> shrinkWHead v

62 P.Literal l -> P.Literal <$> shrink l

67 P.Literal l -> P.Literal <$> shrink l

63 P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

68 P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p)

64− P.Data s ps -> ps ++ (P.Data <$> shrinkWHead s <*> shrink ps)

69+ P.Data s ps -> ps ++ (P.Data <$> shrink s <*> shrink ps)

65 P.Record fs ->

70 P.Record fs ->

66 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

71 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

67 where

72 where

@@ -71,29 +76,33 @@ shrinkWHead :: Arbitrary a => [a] -> [[a]]

71shrinkWHead [] = error "Should be nonempty"

76shrinkWHead [] = error "Should be nonempty"

72shrinkWHead (x:xs) = (x:) <$> shrink xs

77shrinkWHead (x:xs) = (x:) <$> shrink xs

73

78

74−instance Arbitrary T.Type where

79+instance Arbitrary v => Arbitrary (T.Type v) where

75 arbitrary = sized tipe

80 arbitrary = sized tipe

76 where

81 where

77− tipe :: Int -> Gen T.Type

82+ tipe :: Arbitrary v => Int -> Gen (T.Type v)

78 tipe n =

83 tipe n =

79 let depthTipe = tipe =<< choose (0,n)

84 let depthTipe = tipe =<< choose (0,n)

80 field = (,) <$> lowVar <*> depthTipe

85 field = (,) <$> lowVar <*> depthTipe

81 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

86 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

82 fields1 = (:) <$> field <*> fields

87 fields1 = (:) <$> field <*> fields

88+ depthTipes = (:) <$> depthTipe <*> genVector n tipe

83 in

89 in

84 oneof

90 oneof

85 [ T.Lambda <$> depthTipe <*> depthTipe

91 [ T.Lambda <$> depthTipe <*> depthTipe

86 , T.Var <$> lowVar

92 , T.Var <$> lowVar

87− , T.Data <$> capVar <*> genVector n tipe

93+ , T.Type <$> arbitrary

94+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes

88 , T.Record <$> fields <*> pure Nothing

95 , T.Record <$> fields <*> pure Nothing

89− , T.Record <$> fields1 <*> (Just <$> lowVar)

96+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)

90 ]

97 ]

91

98

92 shrink tipe =

99 shrink tipe =

93 case tipe of

100 case tipe of

94 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

101 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

95 T.Var _ -> []

102 T.Var _ -> []

96− T.Data n ts -> ts ++ (T.Data <$> shrinkWHead n <*> shrink ts)

103+ T.Aliased v t -> t : (T.Aliased v <$> shrink t)

104+ T.Type v -> T.Type <$> shrink v

105+ T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)

97 T.Record fs t -> map snd fs ++ record

106 T.Record fs t -> map snd fs ++ record

98 where

107 where

99 record =

108 record =

tests/compiler/test-files/good/Box.elmdeleted−89

@@ -1,89 +0,0 @@

1−

2−module Box where

3−

4−import Math.Vector3 (..)

5−import Math.Matrix4 (..)

6−import Graphics.WebGL (Triangle, zipTriangle, Shader, Model, model, webgl)

7−import Window(dimensions)

8−

9−-- Create a cube in which each point has a color

10−

11−type ColorPoint = { color:Vec3, point:Vec3 }

12−

13−face : Color -> Vec3 -> Vec3 -> Vec3 -> Vec3 -> [Triangle ColorPoint]

14−face color a b c d =

15− let toV3 color =

16− let c = toRgb color

17− in v3 (toFloat c.red / 255) (toFloat c.green / 255) (toFloat c.blue / 255)

18− p = ColorPoint (toV3 color)

19− in

20− [ (p a, p b, p c), (p c, p d, p a) ]

21−

22−cube : [Triangle ColorPoint]

23−cube =

24− let rft = v3 1 1 1 -- right, front, top

25− lft = v3 -1 1 1 -- left, front, top

26− lbt = v3 -1 -1 1

27− rbt = v3 1 -1 1

28− rbb = v3 1 -1 -1

29− rfb = v3 1 1 -1

30− lfb = v3 -1 1 -1

31− lbb = v3 -1 -1 -1

32− in

33− concat [ face green rft rfb rbb rbt -- right

34− , face blue rft rfb lfb lft -- front

35− , face purple lft lfb lbb lbt -- left

36− , face orange rbt rbb lbb lbt -- back

37− ]

38−

39−-- Create the scene

40−

41−main : Signal Element

42−main = webgl (400,400) <~ lift scene angle

43−

44−angle : Signal Float

45−angle = foldp (\dt theta -> theta + dt / 5000) 0 (fps 25)

46−

47−scene : Float -> [Model]

48−scene angle =

49− [ model vertexShader fragmentShader cube (uniforms angle) ]

50−

51−uniforms : Float -> { rotation:Mat4, perspective:Mat4, camera:Mat4, shade:Float }

52−uniforms t =

53− { rotation = mul (makeRotate (3*t) (v3 0 1 0)) (makeRotate (2*t) (v3 1 0 0))

54− , perspective = makePerspective 45 1 0.01 100

55− , camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)

56− , shade = 0.8

57− }

58−

59−-- Shaders

60−

61−vertexShader : Shader { attr | point:Vec3, color:Vec3 }

62− { unif | rotation:Mat4, perspective:Mat4, camera:Mat4 }

63− { vcolor:Vec3 }

64−vertexShader = [glShader|

65−

66−attribute vec3 point;

67−attribute vec3 color;

68−uniform mat4 perspective;

69−uniform mat4 camera;

70−uniform mat4 rotation;

71−varying vec3 vcolor;

72−void main () {

73− gl_Position = perspective * camera * rotation * vec4(point, 1.0);

74− vcolor = color;

75−}

76−

77−|]

78−

79−fragmentShader : Shader {} { u | shade:Float } { vcolor:Vec3 }

80−fragmentShader = [glShader|

81−

82−precision mediump float;

83−uniform float shade;

84−varying vec3 vcolor;

85−void main () {

86− gl_FragColor = shade * vec4(vcolor, 1.0);

87−}

88−

89−|]

tests/compiler/test-files/good/Crate.elmdeleted−85

@@ -1,85 +0,0 @@

1−

2−module Crate where

3−

4−import Http (..)

5−import Math.Vector2 (Vec2)

6−import Math.Vector3 (..)

7−import Math.Matrix4 (..)

8−import Graphics.WebGL (..)

9−

10−-- Define the mesh for a crate

11−crate : [Triangle { pos:Vec3, coord:Vec3 }]

12−crate = concatMap rotatedFace [ (0,0), (90,0), (180,0), (270,0), (0,90), (0,-90) ]

13−

14−rotatedFace : (Float,Float) -> [Triangle { pos:Vec3, coord:Vec3 }]

15−rotatedFace (angleX,angleY) =

16− let x = makeRotate (degrees angleX) (v3 1 0 0)

17− y = makeRotate (degrees angleY) (v3 0 1 0)

18− t = x `mul` y `mul` makeTranslate (v3 0 0 1)

19− in

20− map (mapTriangle (\x -> {x | pos <- mulVec3 t x.pos })) face

21−

22−face : [Triangle { pos:Vec3, coord:Vec3 }]

23−face =

24− let topLeft = { pos = v3 -1 1 0, coord = v3 0 1 0 }

25− topRight = { pos = v3 1 1 0, coord = v3 1 1 0 }

26− bottomLeft = { pos = v3 -1 -1 0, coord = v3 0 0 0 }

27− bottomRight = { pos = v3 1 -1 0, coord = v3 1 0 0 }

28− in

29− [ (topLeft,topRight,bottomLeft), (bottomLeft,topRight,bottomRight) ]

30−

31−-- View

32−view : Float -> Mat4

33−view angle =

34− foldr1 mul [ perspective

35− , camera

36− , makeRotate (3*angle) (v3 0 1 0)

37− , makeRotate (2*angle) (v3 1 0 0)

38− ]

39−

40−perspective : Mat4

41−perspective = makePerspective 45 1 0.01 100

42−

43−camera : Mat4

44−camera = makeLookAt (v3 0 0 5) (v3 0 0 0) (v3 0 1 0)

45−

46−-- Putting it together

47−main : Signal Element

48−main = webgl (400,400) <~ lift2 scene (loadTex "woodCrate.jpg") (view <~ angle)

49−

50−angle : Signal Float

51−angle = foldp (\dt theta -> theta + dt / 10000) 0 (fps 25)

52−

53−scene : Response Texture -> Mat4 -> [Model]

54−scene response view =

55− case response of

56− Waiting -> []

57− Failure _ _ -> []

58− Success tex -> [model vertexShader fragmentShader crate { crate = tex, view = view }]

59−

60−-- Shaders

61−vertexShader : Shader { pos:Vec3, coord:Vec3 } { u | view:Mat4 } { vcoord:Vec2 }

62−vertexShader = [glShader|

63−

64−attribute vec3 pos;

65−attribute vec3 coord;

66−uniform mat4 view;

67−varying vec2 vcoord;

68−void main () {

69− gl_Position = view * vec4(pos, 1.0);

70− vcoord = coord.xy;

71−}

72−

73−|]

74−

75−fragmentShader : Shader {} { u | crate:Texture } { vcoord:Vec2 }

76−fragmentShader = [glShader|

77−

78−precision mediump float;

79−uniform sampler2D crate;

80−varying vec2 vcoord;

81−void main () {

82− gl_FragColor = texture2D(crate, vcoord);

83−}

84−

85−|]

tests/compiler/test-files/good/PortsWithTypeAliases.elmnew file+8

@@ -0,0 +1,8 @@

1+

2+type Point2D = Point Float Float

3+

4+type Point a b = { x:a, y:b }

5+

6+port points : Signal Point2D

7+

8+port pairs : Signal (Point String String)

tests/compiler/test-files/good/woodCrate.JPGdeleted

Binary file not shown.

tests/libraries/LibraryTest.hs+20−14

@@ -19,31 +19,37 @@ main = do

19 unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]

20

21 -- setup actual library tests

22− setCurrentDirectory $ top </> "tests" </> "libraries"

22+ let localCompiler = joinPath [ "dist", "build", "elm", "elm" ]

23− let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]

24 runCmd localCompiler [ "--make"

23 runCmd localCompiler [ "--make"

25 , "--only-js"

24 , "--only-js"

26− , "--src-dir=" ++ top </> "automaton"

25+ , "--src-dir=IO"

27− , "--src-dir=" ++ top </> "IO"

26+ , "--src-dir=Elm-Test"

28− , "--src-dir=" ++ top </> "Elm-Test"

27+ , "--src-dir=" ++ "tests" </> "libraries"

29− , "Test.elm"

28+ , testFile <.> "elm"

30 ]

29 ]

31

30

32 -- run tests

31 -- run tests

33− let ioScript s = top </> "IO" </> s

32+ let files = [ "IO" </> "share" </> "prescript.js"

34− files = [ ioScript "prescript.js"

35 , Elm.runtime

33 , Elm.runtime

36− , "build" </> "Test.js"

34+ , "build" </> testFile <.> "js"

37− , ioScript "handler.js"

35+ , "IO" </> "share" </> "handler.js"

38 ]

36 ]

37+ testRunner = "build" </> "TestRunner.js"

39 exe <- readProcess "cat" files ""

38 exe <- readProcess "cat" files ""

40− writeFile "exe.js" exe

39+ writeFile testRunner exe

41− exitWith =<< waitForProcess =<< (runCommand "node exe.js")

40+ exitCode <- rawSystem "node" [testRunner]

41+ removeDirectoryRecursive "cache"

42+ removeDirectoryRecursive "build"

43+ exitWith exitCode

44+ where

45+ testFile = "tests" </> "libraries" </> "Test"

42

46

43runCmd :: String -> [String] -> IO ()

47runCmd :: String -> [String] -> IO ()

44runCmd cmd args = do

48runCmd cmd args = do

45 putStrLn (cmd ++ " " ++ unwords args)

49 putStrLn (cmd ++ " " ++ unwords args)

46− (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""

50+ (exitCode, stdout, stderr) <- readProcessWithExitCode cmd args ""

51+ putStr stdout

52+ putStr stderr

47 case exitCode of

53 case exitCode of

48 ExitSuccess -> return ()

54 ExitSuccess -> return ()

49− ExitFailure _ -> error stderr

55+ ExitFailure _ -> exitWith exitCode

tests/libraries/Test.elm+4−6

@@ -4,12 +4,12 @@ import ElmTest.Assertion as A

4import ElmTest.Run as R

5import ElmTest.Runner.Console (runDisplay)

6import ElmTest.Test (..)

7−

8import IO.IO (..)

7import IO.IO (..)

9import IO.Runner (Request, Response)

8import IO.Runner (Request, Response)

10import IO.Runner as Run

9import IO.Runner as Run

11

10

12import Test.Array as Array

11import Test.Array as Array

12+import Test.Char as Char

13import Test.Dict as Dict

14import Test.Equality as Equality

15import Test.List as List

@@ -20,6 +20,7 @@ import Test.Trampoline as Trampoline

20tests : Test

21tests = suite "Elm Standard Library Tests"

22 [ Array.tests

23+ , Char.tests

23 , Dict.tests

24 , Dict.tests

24 , Equality.tests

25 , Equality.tests

25 , List.tests

26 , List.tests

@@ -31,10 +32,7 @@ tests = suite "Elm Standard Library Tests"

31console : IO ()

32console : IO ()

32console = runDisplay tests

33console = runDisplay tests

33

34

34−port requests : Signal [{ mPut : Maybe String

35+port requests : Signal Request

35− , mExit : Maybe Int

36− , mGet : Bool

37− }]

38port requests = Run.run responses console

36port requests = Run.run responses console

39

37

40−port responses : Signal (Maybe String)

38+port responses : Signal Response

tests/libraries/Test/Array.elm+5−1

@@ -26,6 +26,8 @@ tests =

26 , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))

27 , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))

28 , test "append" <| assertEqual [42,42,81,81,81] (Array.toList (Array.append (Array.repeat 2 42) (Array.repeat 3 81)))

29+ , test "appendEmpty 1" <| assertEqual [1..33] (Array.toList (Array.append Array.empty (Array.fromList [1..33])))

30+ , test "appendEmpty 2" <| assertEqual [1..33] (Array.toList (Array.append (Array.fromList [1..33]) Array.empty))

29 ]

31 ]

30 getAndSetTests = suite "Get and Set"

32 getAndSetTests = suite "Get and Set"

31 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

33 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

@@ -48,9 +50,11 @@ tests =

48 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

50 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

49 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

51 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

50 , test "indexedMap 2" <| assertEqual [0..99] (Array.toList (Array.indexedMap always (Array.repeat 100 0)))

52 , test "indexedMap 2" <| assertEqual [0..99] (Array.toList (Array.indexedMap always (Array.repeat 100 0)))

51− , test "foldl" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))

53+ , test "foldl 1" <| assertEqual [3,2,1] (Array.foldl (::) [] (Array.fromList [1,2,3]))

54+ , test "foldl 2" <| assertEqual 33 (Array.foldl (+) 0 (Array.repeat 33 1))

52 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

55 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

53 , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))

56 , test "foldr 2" <| assertEqual [1,2,3] (Array.foldr (::) [] (Array.fromList [1,2,3]))

57+ , test "foldr 3" <| assertEqual 53 (Array.foldr (-) 54 (Array.fromList [10,11]))

54 , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x `mod` 2 == 0) (Array.fromList [1..6]))

58 , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x `mod` 2 == 0) (Array.fromList [1..6]))

55 ]

59 ]

56 nativeTests = suite "Conversion to JS Arrays"

60 nativeTests = suite "Conversion to JS Arrays"

tests/libraries/Test/Char.elmnew file+15

@@ -0,0 +1,15 @@

1+module Test.Char (tests) where

2+

3+import Char

4+

5+import ElmTest.Assertion (..)

6+import ElmTest.Test (..)

7+

8+tests : Test

9+tests =

10+ suite "Char"

11+ [ test "toUpper" <| assertEqual 'C' <| Char.toUpper 'c'

12+ , test "toLower" <| assertEqual 'c' <| Char.toLower 'C'

13+ , test "toLocaleUpper" <| assertEqual 'C' <| Char.toLocaleUpper 'c'

14+ , test "toLocaleLower" <| assertEqual 'c' <| Char.toLocaleLower 'C'

15+ ]

tests/libraries/Test/String.elm+20−20

@@ -1,7 +1,7 @@

1module Test.String (tests) where

2

3import List

4−import String (..)

4+import String

5

6import ElmTest.Assertion (..)

7import ElmTest.Test (..)

@@ -9,29 +9,29 @@ import ElmTest.Test (..)

9tests : Test

10tests =

11 let simpleTests = suite "Simple Stuff"

12− [ test "is empty" <| assert (isEmpty "")

12+ [ test "is empty" <| assert (String.isEmpty "")

13− , test "is not empty" <| assert (not (isEmpty ("the world")))

13+ , test "is not empty" <| assert (not (String.isEmpty ("the world")))

14− , test "length" <| assertEqual 11 (length "innumerable")

14+ , test "length" <| assertEqual 11 (String.length "innumerable")

15− , test "endsWith" (assert <| endsWith "ship" "spaceship")

15+ , test "endsWith" (assert <| String.endsWith "ship" "spaceship")

16− , test "reverse" <| assertEqual "desserts" (reverse "stressed")

16+ , test "reverse" <| assertEqual "desserts" (String.reverse "stressed")

17− , test "repeat" <| assertEqual "hahaha" (repeat 3 "ha")

17+ , test "repeat" <| assertEqual "hahaha" (String.repeat 3 "ha")

18 ]

19

20 combiningTests = suite "Combining Strings"

21− [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (uncons "abc")

21+ [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (String.uncons "abc")

22− , test "uncons empty" <| assertEqual Nothing (uncons "")

22+ , test "uncons empty" <| assertEqual Nothing (String.uncons "")

23− , test "append 1" <| assertEqual "butterfly" (append "butter" "fly")

23+ , test "append 1" <| assertEqual "butterfly" (String.append "butter" "fly")

24− , test "append 2" <| assertEqual "butter" (append "butter" "")

24+ , test "append 2" <| assertEqual "butter" (String.append "butter" "")

25− , test "append 3" <| assertEqual "butter" (append "" "butter")

25+ , test "append 3" <| assertEqual "butter" (String.append "" "butter")

26 , test "concat" <| assertEqual "nevertheless" (concat ["never","the","less"])

27− , test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow")

27+ , test "split commas" <| assertEqual ["cat","dog","cow"] (String.split "," "cat,dog,cow")

28− , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (split "/" "home/steve/Desktop/")

28+ , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (String.split "/" "home/steve/Desktop/")

29− , test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"])

29+ , test "join spaces" <| assertEqual "cat dog cow" (String.join " " ["cat","dog","cow"])

30− , test "join slashes" <| assertEqual "home/steve/Desktop" (join "/" ["home","steve","Desktop"])

30+ , test "join slashes" <| assertEqual "home/steve/Desktop" (String.join "/" ["home","steve","Desktop"])

31− , test "slice 1" <| assertEqual "c" (slice 2 3 "abcd")

31+ , test "slice 1" <| assertEqual "c" (String.slice 2 3 "abcd")

32− , test "slice 2" <| assertEqual "abc" (slice 0 3 "abcd")

32+ , test "slice 2" <| assertEqual "abc" (String.slice 0 3 "abcd")

33− , test "slice 3" <| assertEqual "abc" (slice 0 -1 "abcd")

33+ , test "slice 3" <| assertEqual "abc" (String.slice 0 -1 "abcd")

34− , test "slice 4" <| assertEqual "cd" (slice -2 4 "abcd")

34+ , test "slice 4" <| assertEqual "cd" (String.slice -2 4 "abcd")

35 ]

36 in

37 suite "String" [ simpleTests, combiningTests ]