9e7ff43 · elk · git.iko.soy

.gitignore+2

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

11dist

22cabal-dev

3+.cabal-sandbox/

4+cabal.sandbox.config

35*.o

46*.hi

57*.chi

.gitmodules−3

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

11[submodule "IO"]

22 path = IO

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

4−[submodule "automaton"]

5− path = automaton

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

74[submodule "Elm-Test"]

85 path = Elm-Test

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

Elm-Test+1−1

Submodule changed.

Elm.cabal+50−39

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

3737 Elm.Internal.Utils,

3838 Elm.Internal.Version

3939 Hs-Source-Dirs: compiler

40− other-modules: SourceSyntax.Annotation,

41− SourceSyntax.Declaration,

42− SourceSyntax.Expression,

43− SourceSyntax.Helpers,

44− SourceSyntax.Literal,

45− SourceSyntax.Module,

46− SourceSyntax.Pattern,

47− SourceSyntax.PrettyPrint,

48− SourceSyntax.Type,

49− SourceSyntax.Variable,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

46+ AST.Helpers,

47+ AST.Literal,

48+ AST.Module,

49+ AST.Pattern,

50+ AST.PrettyPrint,

51+ AST.Type,

52+ AST.Variable,

5053 Generate.JavaScript,

5154 Generate.JavaScript.Helpers,

5255 Generate.JavaScript.Ports,

56+ Generate.JavaScript.Variable,

5357 Generate.Markdown,

5458 Generate.Html,

5559 Generate.Cases,

5660 Transform.Canonicalize,

61+ Transform.Canonicalize.Environment,

62+ Transform.Canonicalize.Setup,

63+ Transform.Canonicalize.Type,

64+ Transform.Canonicalize.Variable,

5765 Transform.Check,

5866 Transform.Expression,

5967 Transform.Declaration,

6068 Transform.Definition,

61− Transform.SafeNames,

6269 Transform.SortDefinitions,

6370 Transform.Substitute,

6471 Metadata.Prelude,

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

7178 Parse.Parse,

7279 Parse.Pattern,

7380 Parse.Type,

74− Type.Alias,

75− Type.Constrain.Declaration,

7681 Type.Constrain.Expression,

7782 Type.Constrain.Literal,

7883 Type.Constrain.Pattern,

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

123128 Main-is: Compiler.hs

124129 ghc-options: -threaded -O2

125130 Hs-Source-Dirs: compiler

126− other-modules: SourceSyntax.Annotation,

127− SourceSyntax.Declaration,

128− SourceSyntax.Expression,

129− SourceSyntax.Helpers,

130− SourceSyntax.Literal,

131− SourceSyntax.Module,

132− SourceSyntax.Pattern,

133− SourceSyntax.PrettyPrint,

134− SourceSyntax.Type,

135− SourceSyntax.Variable,

131+ other-modules: AST.Annotation,

132+ AST.Declaration,

133+ AST.Expression.General,

134+ AST.Expression.Source,

135+ AST.Expression.Valid,

136+ AST.Expression.Canonical,

137+ AST.Helpers,

138+ AST.Literal,

139+ AST.Module,

140+ AST.Pattern,

141+ AST.PrettyPrint,

142+ AST.Type,

143+ AST.Variable,

136144 Generate.JavaScript,

137145 Generate.JavaScript.Helpers,

138146 Generate.JavaScript.Ports,

147+ Generate.JavaScript.Variable,

139148 Generate.Markdown,

140149 Generate.Html,

141150 Generate.Cases,

142151 Transform.Canonicalize,

152+ Transform.Canonicalize.Environment,

153+ Transform.Canonicalize.Setup,

154+ Transform.Canonicalize.Type,

155+ Transform.Canonicalize.Variable,

143156 Transform.Check,

144157 Transform.Expression,

145158 Transform.Declaration,

146159 Transform.Definition,

147− Transform.SafeNames,

148160 Transform.SortDefinitions,

149161 Transform.Substitute,

150162 Metadata.Prelude,

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

157169 Parse.Parse,

158170 Parse.Pattern,

159171 Parse.Type,

160− Type.Alias,

161− Type.Constrain.Declaration,

162172 Type.Constrain.Expression,

163173 Type.Constrain.Literal,

164174 Type.Constrain.Pattern,

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

208218Executable elm-doc

209219 Main-is: Docs.hs

210220 Hs-Source-Dirs: compiler

211− other-modules: SourceSyntax.Annotation,

212− SourceSyntax.Declaration,

213− SourceSyntax.Expression,

214− SourceSyntax.Helpers,

215− SourceSyntax.Literal,

216− SourceSyntax.Module,

217− SourceSyntax.Pattern,

218− SourceSyntax.PrettyPrint,

219− SourceSyntax.Type,

220− SourceSyntax.Variable,

221+ other-modules: AST.Annotation,

222+ AST.Declaration,

223+ AST.Expression.General,

224+ AST.Helpers,

225+ AST.Literal,

226+ AST.Module,

227+ AST.Pattern,

228+ AST.PrettyPrint,

229+ AST.Type,

230+ AST.Variable,

221231 Parse.Binop,

222232 Parse.Declaration,

223233 Parse.Expression,

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

244254 pretty,

245255 scientific,

246256 text,

257+ transformers >= 0.2,

247258 union-find,

248259 yaml

249260

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

254265 other-modules: Tests.Compiler

255266 Tests.Property

256267 Tests.Property.Arbitrary

257− SourceSyntax.Helpers

258− SourceSyntax.Literal

259− SourceSyntax.PrettyPrint

268+ AST.Helpers

269+ AST.Literal

270+ AST.PrettyPrint

260271 build-depends: test-framework,

261272 test-framework-hunit,

262273 test-framework-quickcheck2 >= 0.3,

IO+1−1

Submodule changed.

automatondeleted−1

Submodule changed.

changelog.md+32−1

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

11

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+

233## 0.12.1

334

4−## Improvements:

35+#### Improvements:

536

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

738 * Json.Value can flow through ports

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

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

11{-# OPTIONS_GHC -W #-}

2−module SourceSyntax.Annotation where

2+module AST.Annotation where

33

44import qualified Text.Parsec.Pos as Parsec

55import qualified Text.PrettyPrint as P

6−import SourceSyntax.PrettyPrint

6+import AST.PrettyPrint

77

88data Annotated annotation expr = A annotation expr

99 deriving (Show)

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Declaration where

2+module AST.Declaration where

33

44import Data.Binary

5−import qualified SourceSyntax.Expression as Expr

6−import qualified SourceSyntax.Type as T

7−import SourceSyntax.PrettyPrint

5+import qualified AST.Expression.Source as Source

6+import qualified AST.Expression.Valid as Valid

7+import qualified AST.Expression.Canonical as Canonical

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

10+import AST.PrettyPrint

811import Text.PrettyPrint as P

912

10−data Declaration' port def

13+data Declaration' port def var

1114 = Definition def

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

13− | TypeAlias String [String] T.Type

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

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

1417 | Port port

1518 | Fixity Assoc Int String

1619 deriving (Show)

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

1821data Assoc = L | N | R

1922 deriving (Eq)

2023

21−data ParsePort

22− = PPAnnotation String T.Type

23− | PPDef String Expr.ParseExpr

24+data RawPort

25+ = PPAnnotation String T.RawType

26+ | PPDef String Source.Expr

2427 deriving (Show)

2528

26−data Port

27− = Out String Expr.Expr T.Type

28− | In String T.Type

29+data Port expr var

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

31+ | In String (T.Type var)

2932 deriving (Show)

3033

31−portName :: Port -> String

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+

40+portName :: Port expr var -> String

3241portName port =

3342 case port of

3443 Out name _ _ -> name

3544 In name _ -> name

3645

37−type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

38−type Declaration = Declaration' Port Expr.Def

39−

4046instance Show Assoc where

4147 show assoc =

4248 case assoc of

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

5460

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

5662

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

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

64+ Pretty (Declaration' port def var) where

5865 pretty decl =

5966 case decl of

6067 Definition def -> pretty def

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

8188 N -> P.empty

8289 R -> P.text "r"

8390

84−instance Pretty ParsePort where

91+instance Pretty RawPort where

8592 pretty port =

8693 case port of

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

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

8996

90−instance Pretty Port where

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

9198 pretty port =

9299 case port of

93100 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

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

77enrich the AST with more information.

88-}

9−module SourceSyntax.Expression where

9+module AST.Expression.General where

1010

11−import SourceSyntax.PrettyPrint

11+import AST.PrettyPrint

1212import Text.PrettyPrint as P

13−import qualified SourceSyntax.Helpers as Help

14−import qualified SourceSyntax.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as Pattern

16−import qualified SourceSyntax.Type as SrcType

17−import qualified SourceSyntax.Literal as Literal

18−import qualified SourceSyntax.Variable as Variable

13+import AST.Type (Type)

14+

15+import qualified AST.Annotation as Annotation

16+import qualified AST.Helpers as Help

17+import qualified AST.Literal as Literal

18+import qualified AST.Pattern as Pattern

19+import qualified AST.Variable as Var

1920

2021---- GENERAL AST ----

2122

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

3435 with information about what module a variable came from.

3536

3637-}

37−type GeneralExpr annotation definition variable =

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

38+type Expr annotation definition variable =

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

3940

40−data GeneralExpr' ann def var

41+data Expr' ann def var

4142 = Literal Literal.Literal

4243 | Var var

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

44− | ExplicitList [GeneralExpr ann def var]

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

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

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

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

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

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

51− | Data String [GeneralExpr ann def var]

52− | Access (GeneralExpr ann def var) String

53− | Remove (GeneralExpr ann def var) String

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

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

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

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

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

45+ | ExplicitList [Expr ann def var]

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

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

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

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

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

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

52+ | Data String [Expr ann def var]

53+ | Access (Expr ann def var) String

54+ | Remove (Expr ann def var) String

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

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

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

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

5859 -- for type checking and code gen only

59− | PortIn String SrcType.Type

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

60+ | PortIn String (Type var)

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

6162 | GLShader String String Literal.GLShaderTipe

6263 deriving (Show)

6364

6465

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−

9166---- UTILITIES ----

9267

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

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

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

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)

9573

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

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

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

9876

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

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

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

10179delist _ = []

10280

10381saveEnvName :: String

10482saveEnvName = "_save_the_environment!!!"

10583

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

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

10785dummyLet defs =

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

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

10987

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

11189 pretty expr =

11290 case expr of

11391 Literal lit -> pretty lit

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

11896

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

12098

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

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

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

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

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

123102

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 ]

125104 where

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

105+ op' = Var.toString op

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

127107

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

129109 where

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

179159

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

181161

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

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

183163

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

185165

186166 PortOut _ _ signal -> pretty signal

187167

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]

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

207170 case expr of

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

209172 _ -> [annExpr]

210173

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)

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

213176 case expr of

214177 Lambda pattern body ->

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

217180

218181 _ -> ([], lexpr)

219182

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

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

222185 where

223186 needed =

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

228191 MultiIf _ -> True

229192 Let _ _ -> True

230193 Case _ _ -> True

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

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Helpers where

2+module AST.Helpers where

33

44import qualified Data.Char as Char

55

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

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

11{-# OPTIONS_GHC -Wall #-}

2−module SourceSyntax.Literal where

2+module AST.Literal where

33

4+import AST.PrettyPrint

45import Data.Map (Map)

5−import SourceSyntax.PrettyPrint

66import qualified Text.PrettyPrint as PP

77

88data 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

13

2−module SourceSyntax.PrettyPrint where

3−

4−import Text.PrettyPrint

5−import qualified SourceSyntax.Helpers as Help

4+import Control.Monad.Trans.Error

5+import Text.PrettyPrint as P

6+import qualified AST.Helpers as Help

67

78class Pretty a where

89 pretty :: a -> Doc

910

10−instance Pretty () where

11− pretty () = empty

11+instance Pretty Doc where

12+ pretty doc = doc

13+

14+instance Pretty String where

15+ pretty = P.text

1216

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

1418renderPretty e = render (pretty e)

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

2125

2226variable :: String -> Doc

2327variable x =

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

25− else text (reprime x)

26−

27−reprime :: String -> String

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

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

2929

3030eightyCharLines :: Int -> String -> String

3131eightyCharLines indent message = answer

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

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

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

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

1010import System.Directory

1111import System.FilePath as FP

1212

13−import qualified SourceSyntax.Module as Module

13+import qualified AST.Module as Module

1414import qualified Parse.Parse as Parse

1515import qualified Elm.Internal.Paths as Path

1616import qualified Elm.Internal.Name as N

compiler/Build/File.hs+15−17

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

2323import qualified Build.Utils as Utils

2424import qualified Generate.JavaScript as JS

2525import qualified Parse.Module as Parser

26−import qualified SourceSyntax.Module as M

27−import qualified Transform.Canonicalize as Canonical

26+import qualified AST.Module as Module

2827

2928-- Reader: Runtime flags, always accessible

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

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

3332type Build a = BuildT IO a

3433

3534-- Interfaces, remembering if something was recompiled

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

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

3736

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

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

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

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

4039evalBuild flags interfaces build =

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

4241 return (fmap snd ifaces, getLast moduleNames)

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

4544

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

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

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

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

4948build flags interfaces files =

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

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

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

5655 | null ports = return ()

5756 | otherwise = Print.failure msg

5857 where

59− ports = M.iPorts iface

58+ ports = Module.iPorts iface

6059 msg = concat

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

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

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

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

124123 case Interface.isValid filePath iface of

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

129126 update name interface False

130127

131128 Left err -> liftIO $ Print.failure err

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

142139 createDirectoryIfMissing True (Flag.cache_dir flags)

143140 createDirectoryIfMissing True (Flag.build_dir flags)

144141

145− metaModule <-

142+ canonicalModule <-

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

147144 Right modul -> return modul

148145 Left errors -> do Print.errors errors

149146 exitFailure

150147

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

152150

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

154− generateCache name newInters metaModule

151+ let newInters = Module.toInterface canonicalModule

152+ generateCache name newInters canonicalModule

155153 update name newInters True

156154

157155 where

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

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

165163 , "( " ++ filePath ++ " )" ]

166164

167− generateCache name interfs metaModule = do

165+ generateCache name interfs canonicalModule = do

168166 flags <- ask

169167 liftIO $ do

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

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

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

174172

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

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

176174update name inter wasUpdated =

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

178176 tell (Last . Just $ name)

compiler/Build/Flags.hs+27−11

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

99 , files :: [FilePath]

1010 , set_runtime :: Maybe FilePath

1111 , get_runtime :: Bool

12+ , bundle_runtime :: Bool

1213 , only_js :: Bool

1314 , print_types :: Bool

1415 , scripts :: [FilePath]

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

1819 , src_dir :: [FilePath]

1920 }

2021 deriving (Data,Typeable,Show,Eq)

21−

22+

23+flags :: Flags

2224flags = Flags

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

26+

2427 , make = False

25− &= help "automatically compile dependencies."

28+ &= help "automatically compile dependencies."

29+

2630 , only_js = False

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

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

32+

2833 , 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+

3036 , 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+

3239 , 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+

3442 , 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+

3648 , 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+

3851 , 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+

4054 , 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+

4257 , print_types = False

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

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

59+

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

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

4662 &= 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

77import qualified Build.Print as Print

88import qualified Elm.Internal.Version as Version

99import System.Directory (doesFileExist)

10−import SourceSyntax.Module

10+import AST.Module as Module

1111

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

1313load filePath =

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

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

2929 ]

3030

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

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

3232isValid filePath (name, interface) =

3333 let version = iVersion interface in

3434 if version == Version.elmVersion

compiler/Build/Print.hs+7−25

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

55

66import qualified Data.Map as Map

77import qualified Data.List as List

8−import qualified SourceSyntax.Type as T

9−import qualified SourceSyntax.Module as M

10−import qualified SourceSyntax.PrettyPrint as Pretty

11−import qualified Type.Alias as Alias

8+import qualified AST.Module as Module

9+import qualified AST.PrettyPrint as Pretty

1210import qualified Text.PrettyPrint as P

1311

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

15−metaTypes interfaces meta =

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 =

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

13+types ts =

2814 do putStrLn ""

29− mapM_ printType (Map.toList types')

15+ mapM_ printType (Map.toList ts)

3016 putStrLn ""

3117 where

32− rules = Alias.rules interfaces aliases imports

33−

3418 printType (n,t) = do

3519 print $ P.hsep [ Pretty.variable n

3620 , P.text ":"

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

21+ , Pretty.pretty t ]

3822

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

4024errors errs =

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

4226

4327failure :: String -> IO a

44−failure msg =

45− do hPutStrLn stderr msg

46− exitFailure

28+failure msg = hPutStrLn stderr msg >> exitFailure

compiler/Build/Source.hs+21−43

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

22module Build.Source (build) where

33

44import qualified Data.Map as Map

5−import System.FilePath as FP

65import Text.PrettyPrint (Doc)

76

8−import SourceSyntax.Declaration

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

7+import AST.Module as Module

138import qualified Parse.Parse as Parse

149import qualified Metadata.Prelude as Prelude

1510import qualified Transform.Check as Check

16−import qualified Transform.SortDefinitions as SD

1711import qualified Type.Inference as TI

18−import qualified Type.Constrain.Declaration as TcDecl

1912import qualified Transform.Canonicalize as Canonical

2013

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

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

2215build 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)))

2517 . concatMap iFixities $ Map.elems interfaces

2618

27− Module names exs ims decls <- do

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

29− case Check.mistakes decls of

30− [] -> return modul

31− ms -> Left ms

32−

33− let exports'

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 $

42− MetadataModule

43− { names = names

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

57−

58− return $ metaModule { types = types }

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

20+ validModule <- do

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

22+ case Check.mistakes (body modul) of

23+ [] -> return modul

24+ ms -> Left ms

25+

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

27+ canonicalModule <- Canonical.module' interfaces validModule

28+

29+ -- Run type inference on the program.

30+ types <- TI.infer interfaces canonicalModule

31+

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

2525

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

2727compileArgs flags =

28− do when (Flag.get_runtime flags) $

29− do putStrLn Path.runtime

30− exitSuccess

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

29+ putStrLn Path.runtime

30+ exitSuccess

3131 case Flag.files flags of

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

33− fs -> mapM_ (build flags) fs

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

33+ fs -> mapM_ (build flags) fs

3434

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

3636build flags rootFile =

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

5050 (extension, code) <-

5151 if Flag.only_js flags

5252 then do putStr "Generating JavaScript ... "

53− return ("js", js)

53+ makeJs js

5454 else do putStr "Generating HTML ... "

55− return (makeHtml js moduleName)

55+ makeHtml js moduleName

5656

5757 let targetFile = Utils.buildPath flags rootFile extension

5858 createDirectoryIfMissing True (takeDirectory targetFile)

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

6565 src <- BS.readFile filePath

6666 return (BS.append src js)

6767

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

6974

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

71− where

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

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

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

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

86+ where

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

88+ html runtime =

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

compiler/Docs.hs+29−19

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

1+{-# OPTIONS_GHC -W #-}

12{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}

23module Main where

34

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

1617import qualified Data.ByteString.Lazy as BS

1718import qualified Data.Text as Text

1819

19−import qualified SourceSyntax.Helpers as Help

20−import qualified SourceSyntax.Type as T

21−import qualified SourceSyntax.Expression as E

22−import qualified SourceSyntax.Declaration as D

20+import qualified AST.Helpers as Help

21+import qualified AST.Type as T

22+import qualified AST.Declaration as D

23+import qualified AST.Expression.Source as Src

24+import qualified AST.Variable as Var

2325

2426import Text.Parsec hiding (newline,spaces)

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

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

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

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

7678

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

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

7880moduleDocs = do

7981 optional freshLine

8082 (names,exports) <- moduleDef

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

8385 structure <- docComment

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

8587

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

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

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

8890

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

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

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

9193 where

9294 uncommentable = do

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

106108documentToJson name exports structure things =

107109 object $ [ "name" .= name

108110 , "document" .= structure

109− , "values" .= toList values

110− , "aliases" .= toList aliases

111− , "datatypes" .= toList adts

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

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

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

112114 ]

115+{--

113116 where

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

115118

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

120123 case Map.null exportMap of

121124 True -> dict

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

123−

126+--}

127+{--

124128collect infixes types aliases adts things =

125129 case things of

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

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

138142 case decl of

139143 D.Fixity assoc prec name ->

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

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

143147 D.TypeAlias name vars tipe ->

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

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

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

148152 fields = ["typeVariables" .= vars

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

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

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

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

153157 obj name fields =

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

155−

156−instance ToJSON T.Type where

159+--}

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

157161 toJSON tipe =

158162 object $

159163 case tipe of

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

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

169173 , "name" .= toJSON x

170174 ]

171−

172− T.Data name ts ->

175+

176+ T.Type name ->

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

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

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

180+ ]

181+

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

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

174− , "name" .= toJSON name

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

175185 , "args" .= map toJSON ts

176186 ]

177187

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

181191 , "extension" .= toJSON ext

182192 ]

183193

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

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

185195ctorToJson tipe (ctor, tipes) =

186196 object [ "name" .= ctor

187197 , "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−

51Name: Elm

6−Version: 0.8.0.3

2+Version: 0.12

73Synopsis: The Elm language module.

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

95 It is a statically/strongly typed, functional reactive

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

1814

1915Author: Evan Czaplicki

2016Maintainer: info@elm-lang.org

2218

2319Category: Compiler, Language

2420

2521Build-type: Custom

2622

27−Extra-source-files: changelog.txt

28−Data-dir: dist/data

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

30−Cabal-version: >=1.8

23+Extra-source-files: changelog.md

24+Data-dir: data

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

26+Cabal-version: >=1.9

3127

3228source-repository head

3329 type: git

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

3531

3632Library

37− exposed-modules: Language.Elm,

38− Language.Elm.Quasi

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

34+ Elm.Internal.Documentation,

35+ Elm.Internal.Name,

36+ Elm.Internal.Paths,

37+ Elm.Internal.Utils,

38+ Elm.Internal.Version

3939 Hs-Source-Dirs: compiler

40− other-modules: Unique,

41− SourceSyntax.Helpers,

42− SourceSyntax.Location,

43− SourceSyntax.Literal,

44− SourceSyntax.Pattern,

45− SourceSyntax.Expression,

46− SourceSyntax.Declaration,

47− SourceSyntax.Module,

40+ other-modules: AST.Annotation,

41+ AST.Declaration,

42+ AST.Expression.General,

43+ AST.Expression.Source,

44+ AST.Expression.Valid,

45+ AST.Expression.Canonical,

46+ AST.Helpers,

47+ AST.Literal,

48+ AST.Module,

49+ AST.Pattern,

50+ AST.PrettyPrint,

51+ AST.Type,

52+ AST.Variable,

4853 Generate.JavaScript,

49− Generate.Noscript,

54+ Generate.JavaScript.Helpers,

55+ Generate.JavaScript.Ports,

56+ Generate.Markdown,

5057 Generate.Html,

5158 Generate.Cases,

59+ Transform.Canonicalize,

60+ Transform.Check,

61+ Transform.Expression,

62+ Transform.Declaration,

63+ Transform.Definition,

64+ Transform.SortDefinitions,

5265 Transform.Substitute,

53− Transform.Optimize,

54− Metadata.Libraries,

55− Metadata.LoadLibraries,

56− Initialize,

66+ Metadata.Prelude,

5767 Parse.Binop,

68+ Parse.Declaration,

5869 Parse.Expression,

59− Parse.Foreign,

6070 Parse.Helpers,

71+ Parse.Literal,

6172 Parse.Module,

62− Parse.Parser,

73+ Parse.Parse,

6374 Parse.Pattern,

6475 Parse.Type,

65− Types.Alias,

66− Types.Types,

67− Types.Constrain,

68− Types.Hints,

69− Types.Solver,

70− Types.Substitutions,

71− Types.Unify,

76+ Type.Alias,

77+ Type.Constrain.Expression,

78+ Type.Constrain.Literal,

79+ Type.Constrain.Pattern,

80+ Type.Environment,

81+ Type.ExtraChecks,

82+ Type.Fragment,

83+ Type.Inference,

84+ Type.PrettyPrint,

85+ Type.Solve,

86+ Type.State,

87+ Type.Type,

88+ Type.Unify,

89+ Build.Dependencies,

90+ Build.File,

91+ Build.Flags,

92+ Build.Interface,

93+ Build.Print,

94+ Build.Source,

95+ Build.Utils,

7296 Paths_Elm

7397

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,

75105 containers >= 0.3,

76− transformers >= 0.2,

106+ directory,

107+ filepath,

108+ indents,

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

110+ language-glsl,

77111 mtl >= 2,

78− deepseq,

112+ pandoc >= 1.10,

79113 parsec >= 3.1.1,

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

81− blaze-markup == 0.5.1.*,

114+ pretty,

82115 text,

83− shakespeare >= 1,

84− template-haskell,

85− pandoc >= 1.10,

86− bytestring,

87− uniplate,

88− hjsmin,

89− indents,

90− filepath,

91− json,

92− directory

116+ transformers >= 0.2,

117+ union-find,

118+ unordered-containers

93119

94120Executable elm

95121 Main-is: Compiler.hs

122+ ghc-options: -threaded -O2

96123 Hs-Source-Dirs: compiler

97− other-modules: Unique,

98− SourceSyntax.Helpers,

99− SourceSyntax.Location,

100− SourceSyntax.Literal,

101− SourceSyntax.Pattern,

102− SourceSyntax.Expression,

103− SourceSyntax.Declaration,

104− SourceSyntax.Module,

124+ other-modules: AST.Annotation,

125+ AST.Declaration,

126+ AST.Expression.General,

127+ AST.Expression.Source,

128+ AST.Expression.Valid,

129+ AST.Expression.Canonical,

130+ AST.Helpers,

131+ AST.Literal,

132+ AST.Module,

133+ AST.Pattern,

134+ AST.PrettyPrint,

135+ AST.Type,

136+ AST.Variable,

105137 Generate.JavaScript,

106− Generate.Noscript,

138+ Generate.JavaScript.Helpers,

139+ Generate.JavaScript.Ports,

140+ Generate.Markdown,

107141 Generate.Html,

108142 Generate.Cases,

143+ Transform.Canonicalize,

144+ Transform.Check,

145+ Transform.Expression,

146+ Transform.Declaration,

147+ Transform.Definition,

148+ Transform.SortDefinitions,

109149 Transform.Substitute,

110− Transform.Optimize,

111− Metadata.Libraries,

112− Metadata.LoadLibraries,

113− Initialize,

150+ Metadata.Prelude,

114151 Parse.Binop,

152+ Parse.Declaration,

115153 Parse.Expression,

116− Parse.Foreign,

117154 Parse.Helpers,

155+ Parse.Literal,

118156 Parse.Module,

119− Parse.Parser,

157+ Parse.Parse,

120158 Parse.Pattern,

121159 Parse.Type,

122− Types.Alias,

123− Types.Types,

124− Types.Constrain,

125− Types.Hints,

126− Types.Solver,

127− Types.Substitutions,

128− Types.Unify,

160+ Type.Alias,

161+ Type.Constrain.Expression,

162+ Type.Constrain.Literal,

163+ Type.Constrain.Pattern,

164+ Type.Environment,

165+ Type.ExtraChecks,

166+ Type.Fragment,

167+ Type.Inference,

168+ Type.PrettyPrint,

169+ Type.Solve,

170+ Type.State,

171+ Type.Type,

172+ Type.Unify,

173+ Build.Dependencies,

174+ Build.File,

175+ Build.Flags,

176+ Build.Interface,

177+ Build.Print,

178+ Build.Source,

179+ Build.Utils,

129180 Paths_Elm

130181

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,

132189 containers >= 0.3,

133− transformers >= 0.2,

190+ directory,

191+ filepath,

192+ indents,

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

194+ language-glsl,

134195 mtl >= 2,

135− deepseq,

136− parsec >= 3.1.1,

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

138− blaze-markup == 0.5.1.*,

139− cmdargs,

140196 pandoc >= 1.10,

141− bytestring,

142− uniplate,

143− hjsmin,

144− indents,

145− filepath,

146− json,

147− directory

197+ parsec >= 3.1.1,

198+ pretty,

199+ text,

200+ transformers >= 0.2,

201+ union-find,

202+ unordered-containers

148203

149204Executable elm-doc

150205 Main-is: Docs.hs

151206 Hs-Source-Dirs: compiler

152− other-modules: SourceSyntax.Helpers,

153− SourceSyntax.Location,

154− SourceSyntax.Literal,

155− SourceSyntax.Pattern,

156− SourceSyntax.Expression,

157− SourceSyntax.Declaration,

158− SourceSyntax.Module,

207+ other-modules: AST.Annotation,

208+ AST.Declaration,

209+ AST.Expression.General,

210+ AST.Helpers,

211+ AST.Literal,

212+ AST.Module,

213+ AST.Pattern,

214+ AST.PrettyPrint,

215+ AST.Type,

216+ AST.Variable,

217+ Parse.Binop,

218+ Parse.Declaration,

219+ Parse.Expression,

159220 Parse.Helpers,

160− Parse.Module

221+ Parse.Literal,

222+ Parse.Module,

223+ Parse.Pattern,

224+ Parse.Type

161225

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,

163232 containers >= 0.3,

164− transformers >= 0.2,

233+ directory,

234+ filepath,

235+ indents,

236+ language-glsl,

165237 mtl >= 2,

166− parsec >= 3.1.1,

167238 pandoc >= 1.10,

168− cmdargs,

169− filepath,

170− indents

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,

265+ cmdargs,

266+ containers >= 0.3,

267+ directory,

268+ Elm,

269+ filemanip,

270+ filepath,

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

55import qualified Data.List as List

66import qualified Generate.JavaScript as JS

77import qualified Build.Source as Source

8−import Parse.Module (getModuleName)

8+import qualified Parse.Module as Parser

9+import qualified AST.Module as M

910import Parse.Parse (dependencies)

10−import qualified SourceSyntax.Module as M

1111import qualified Text.PrettyPrint as P

1212import qualified Metadata.Prelude as Prelude

1313import System.IO.Unsafe

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

2626

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

2828moduleName :: String -> Maybe String

29−moduleName = getModuleName

29+moduleName = Parser.getModuleName

3030

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

3232-- source program.

compiler/Generate/Cases.hs+41−20

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

1+{-# OPTIONS_GHC -W #-}

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

23

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

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

67import Data.List (groupBy,sortBy)

78import Data.Maybe (fromMaybe)

89

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import SourceSyntax.Literal

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Variable as V

10+import AST.Annotation

11+import AST.Expression.General

12+import AST.Expression.Canonical as Canonical

13+import AST.Literal

14+import qualified AST.Pattern as P

15+import qualified AST.Variable as Var

1416import Transform.Substitute

1517

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

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

1719toMatch patterns = do

1820 v <- newVar

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

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

2729 = Match String [Clause] Match

2830 | Break

2931 | Fail

30− | Other Expr

32+ | Other Canonical.Expr

3133 | Seq [Match]

3234 deriving Show

3335

3436data Clause =

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

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

3638 deriving Show

3739

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

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

4244 Fail -> Fail

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

4446 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

4648 Match n cs m ->

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

4850 where

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

5052 clauseSubst (Clause c vs m) =

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

5254

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

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

5357isCon (p:_, _) =

5458 case p of

5559 P.Data _ _ -> True

5660 P.Literal _ -> True

5761 _ -> False

5862

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

5964isVar p = not (isCon p)

6065

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

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

6267match [] [] def = return def

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

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

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

7075 where

7176 cs' = map (dealias v) cs

7277

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

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

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

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

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

7783 _ -> c

7884

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"

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

8188 where

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

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

8391 where

8492 subOnePattern pattern e =

8593 case pattern of

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

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

8795 P.Anything -> e

8896 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"

9099

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"

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

93103 where

94104 css = groupBy eq (sortBy cmp cs)

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

97107 case (p1,p2) of

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

99109 _ -> compare p1 p2

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

100111

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

102113 case (p1,p2) of

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

104115 _ -> p1 == p2

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

105117

106118 toClause cs =

107119 case head cs of

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

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

122+ _ -> noMatch "matchCon"

110123

111−matchClause :: Either String Literal

124+matchClause :: Either Var.Canonical Literal

112125 -> [String]

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

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

114127 -> Match

115128 -> State Int Clause

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

116130matchClause c (_:vs) cs def =

117131 do vs' <- getVars

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

119133 where

120−

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

121135 flatten (p:ps, e) =

122136 case p of

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

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

139+ _ -> noMatch "matchClause.flatten"

125140

126141 getVars =

127142 case head cs of

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

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

145+ _ -> noMatch "matchClause.getVars"

130146

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

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

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

133149 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 =

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

1818 preEscapedToMarkup $ BS.unpack src

1919

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

21−generate libLoc title scripts moduleName noscript =

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

21+generate runtime title scripts moduleName noscript =

2222 H.docTypeHtml $ do

2323 H.head $ do

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

2525 H.title . H.toHtml $ title

26− makeScript (Link libLoc)

26+ makeScript runtime

2727 mapM_ makeScript scripts

2828 H.body $ do

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

compiler/Generate/JavaScript.hs+152−118

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

1010import Language.ECMAScript3.PrettyPrint

1111import Language.ECMAScript3.Syntax

1212

13−import Generate.JavaScript.Helpers

13+import Generate.JavaScript.Helpers as Help

1414import qualified Generate.Cases as Case

1515import qualified Generate.JavaScript.Ports as Port

16+import qualified Generate.JavaScript.Variable as Var

1617import qualified Generate.Markdown as MD

17−import SourceSyntax.Annotation

18−import SourceSyntax.Expression

19−import qualified SourceSyntax.Helpers as Help

20−import SourceSyntax.Literal

21−import SourceSyntax.Module

22−import qualified SourceSyntax.Pattern as P

23−import SourceSyntax.PrettyPrint (renderPretty)

24−import qualified SourceSyntax.Variable as V

25−import qualified Transform.SafeNames as MakeSafe

18+

19+import AST.Annotation

20+import AST.Module

21+import AST.Expression.General

22+import qualified AST.Expression.Canonical as Canonical

23+import qualified AST.Module as Module

24+import qualified AST.Helpers as Help

25+import AST.Literal

26+import qualified AST.Pattern as P

27+import qualified AST.Variable as Var

2628

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

2830varDecl x expr =

2931 VarDecl () (var x) (Just expr)

3032

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

32−include alias moduleName =

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

34−

35−internalImports :: String -> Statement ()

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

3634internalImports name =

37− VarDeclStmt ()

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

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

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

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

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

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

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

36+ , include "_U" "Utils"

37+ , include "_L" "List"

38+ , include "_A" "Array"

39+ , include "_E" "Error"

40+ , varDecl Help.localModuleName (string name)

4441 ]

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]

4552

4653literal :: Literal -> Expression ()

4754literal lit =

4855 case lit of

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

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

5057 Str s -> string s

5158 IntNum n -> IntLit () n

5259 FloatNum n -> NumLit () n

5360 Boolean b -> BoolLit () b

5461

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

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

5663expression (A region expr) =

5764 case expr of

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

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

5966

6067 Literal lit -> return $ literal lit

6168

6269 Range lo hi ->

6370 do lo' <- expression lo

6471 hi' <- expression hi

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

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

6673

6774 Access e x ->

6875 do e' <- expression e

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

7077

7178 Remove e x ->

7279 do e' <- expression e

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

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

7481

7582 Insert e x v ->

7683 do v' <- expression v

7784 e' <- expression e

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

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

7986

8087 Modify e fs ->

8188 do e' <- expression e

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

8390 v' <- expression v

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

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

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

8693

8794 Record fields ->

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

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

106113 where

107114 depattern (args, body) pattern =

108115 case pattern of

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

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

110117 _ -> do arg <- Case.newVar

111118 return ( args ++ [arg]

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

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

113120

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

115122

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

142149 MultiIf branches ->

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

144151 return $ case last branches of

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

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

153+ safeIfs branches'

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

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

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

148156 where

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

150158 ifs branches finally = foldr iff finally branches

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

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

155163 (revisedMatch, stmt) <-

156164 case e of

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

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

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

159167 _ ->

160168 do e' <- expression e

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

164172

165173 ExplicitList es ->

166174 do es' <- mapM expression es

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

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

168176

169177 Data name es ->

170178 do es' <- mapM expression es

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

175183

176184 Markdown uid doc es ->

177185 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')

179187 where

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

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

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

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

185193

186194 PortIn name tipe ->

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

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

196+ [ string name, Port.incoming tipe ]

188197

189198 PortOut name tipe value ->

190199 do value' <- expression value

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

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

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

193202

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

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

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

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

196205 expr' <- expression expr

197206 let assign x = varDecl x expr'

198207 case pattern of

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

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

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

203212 | otherwise ->

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

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

205214

206215 P.Record fields ->

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

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

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

209218

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

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

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

212221 where

213222 vars = getVars patterns

214223 getVars patterns =

215224 case patterns of

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

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

217226 [] -> Just []

218227 _ -> Nothing

219228

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

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

221230 setup vars

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

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

224233

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

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

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

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

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

236+ exception = Help.throw "Case" region

228237

229238 _ ->

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

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

232241 where

233242 vars = P.boundVarList pattern

234− mkVar = A region . rawVar

243+ mkVar = A region . localVar

235244 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

237246

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

239248match region mtch =

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

248257 _ -> False

249258

250259 access name

251− | any isLiteral clauses = obj name

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

260+ | any isLiteral clauses = obj [name]

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

253262

254263 format isChars e

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

256265 | otherwise = e

257266

258267 Case.Fail ->

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

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

260269

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

262271

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

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

284293 Right (Boolean b) -> BoolLit () b

285294 Right lit -> literal lit

286− Left name -> string $ case List.elemIndices '.' name of

287− [] -> name

288− is -> drop (last is + 1) name

295+ Left (Var.Canonical _ name) ->

296+ string name

289297

290−flattenLets :: [Def] -> Expr -> ([Def], Expr)

298+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

291299flattenLets defs lexpr@(A _ expr) =

292300 case expr of

293301 Let ds body -> flattenLets (defs ++ ds) body

294302 _ -> (defs, lexpr)

295303

296−generate :: MetadataModule -> String

297−generate unsafeModule =

298− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

299− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

304+generate :: CanonicalModule -> String

305+generate modul =

306+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

307+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

300308 where

301− modul = MakeSafe.metadataModule unsafeModule

302− thisModule = dotSep ("_elm" : names modul ++ ["values"])

309+ names :: [String]

310+ names = Module.names modul

311+

312+ thisModule :: Expression ()

313+ thisModule = obj ("_elm" : names ++ ["values"])

314+

315+ programStmts :: [Statement ()]

303316 programStmts =

304317 concat

305− [ [ ExprStmt () $ string "use strict" ]

306− , setup (Just "_elm") (names modul ++ ["values"])

318+ [ [ ExprStmt () (string "use strict") ]

319+ , setup "_elm" (names ++ ["values"])

307320 , [ IfSingleStmt () thisModule (ret thisModule) ]

308− , [ internalImports (List.intercalate "." (names modul)) ]

309− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

310− , [ assign ["_op"] (ObjectLit () []) ]

311− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

321+ , [ VarDeclStmt () localVars ]

322+ , body

312323 , [ jsExports ]

313324 , [ ret thisModule ]

314325 ]

315326

316− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

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+

351+ jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

317352 where

318− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul

353+ exs = map entry $ "_op" : concatMap extract (exports modul)

319354 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

320361

321362 assign path expr =

322363 case path of

323364 [x] -> VarDeclStmt () [ varDecl x expr ]

324365 _ -> ExprStmt () $

325− AssignExpr () OpAssign (LDot () (dotSep (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"

366+ AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr

331367

332− setup namespace path = map create paths

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

340−binop region op e1 e2 =

341− case op of

342− "Basics.." ->

368+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

369+ -> State Int (Expression ())

370+binop region func@(Var.Canonical home op) e1 e2 =

371+ case (home, op) of

372+ (Var.Module "Basics", ".") ->

343373 do es <- mapM expression (e1 : collect [] e2)

344374 return $ ["$"] ==> foldr (<|) (ref "$") es

345− "Basics.<|" ->

375+

376+ (Var.Module "Basics", "<|") ->

346377 do e2' <- expression e2

347378 es <- mapM expression (collect [] e1)

348379 return $ foldr (<|) e2' es

349− "List.++" ->

380+

381+ (Var.Module "List", "++") ->

350382 do e1' <- expression e1

351383 e2' <- expression e2

352− return $ obj "_L.append" `call` [e1', e2']

353− "::" -> expression (A region (Data "::" [e1,e2]))

354− _ ->

384+ return $ _List "append" `call` [e1', e2']

385+

386+ (Var.BuiltIn, "::") ->

387+ expression (A region (Data "::" [e1,e2]))

388+

389+ (Var.Module "Basics", _) ->

355390 do e1' <- expression e1

356391 e2' <- expression e2

357− return $ case Map.lookup op opDict of

392+ return $ case Map.lookup op basicOps of

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

360401 where

361402 collect es e =

362403 case e of

363− A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

404+ A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->

405+ collect (es ++ [e1]) e2

364406 _ -> es ++ [e]

365407

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)

373−

374− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]

375− infixOp str op = specialOp str (InfixExpr () op)

408+ basicOps = Map.fromList (infixOps ++ specialOps)

376409

377− infixOps = concat

410+ infixOps =

411+ let infixOp str op = (str, InfixExpr () op) in

378412 [ infixOp "+" OpAdd

379413 , infixOp "-" OpSub

380414 , infixOp "*" OpMul

@@ -383,16 +417,16 @@ binop region op e1 e2 =

383417 , infixOp "||" OpLOr

384418 ]

385419

386− specialOps = concat

387− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

388− , specialOp "|>" $ flip (<|)

389− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

390− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

391− , specialOp "<" $ cmp OpLT 0

392− , specialOp ">" $ cmp OpGT 0

393− , specialOp "<=" $ cmp OpLT 1

394− , specialOp ">=" $ cmp OpGT (-1)

395− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

420+ specialOps =

421+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]

422+ , (,) "|>" $ flip (<|)

423+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]

424+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])

425+ , (,) "<" $ cmp OpLT 0

426+ , (,) ">" $ cmp OpGT 0

427+ , (,) "<=" $ cmp OpLT 1

428+ , (,) ">=" $ cmp OpGT (-1)

429+ , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

396430 ]

397431

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

11{-# OPTIONS_GHC -W #-}

22module Generate.JavaScript.Helpers where

33

4−import qualified SourceSyntax.Helpers as Help

4+import AST.Annotation (Region)

5+import qualified AST.PrettyPrint as PP

56import Language.ECMAScript3.Syntax

67

7−split :: String -> [String]

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]

8+-- Creating Variables

159

10+var :: String -> Id ()

1611var name = Id () name

12+

13+ref :: String -> Expression ()

1714ref name = VarRef () (var name)

15+

16+prop :: String -> Prop ()

1817prop name = PropId () (var name)

19−f <| x = CallExpr () f [x]

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

18+

2419string = StringLit ()

2520

26−dotSep vars =

21+obj :: [String] -> Expression ()

22+obj vars =

2723 case vars of

2824 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

2925 [] -> error "dotSep must be called on a non-empty list of variables"

3026

31−obj = dotSep . split

27+-- Specific Utilities

3228

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

3356equal a b = InfixExpr () OpStrictEq a b

57+

58+instanceof :: String -> Expression () -> Expression ()

3459instanceof tipe x =

3560 InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

61+

62+typeof :: String -> Expression () -> Expression ()

3663typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

64+

65+member :: String -> Expression () -> Expression ()

3766member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hs+82−64

@@ -2,8 +2,9 @@

22module Generate.JavaScript.Ports (incoming, outgoing) where

33

44import Generate.JavaScript.Helpers

5−import qualified SourceSyntax.Helpers as Help

6−import SourceSyntax.Type as T

5+import qualified Generate.JavaScript.Variable as V

6+import AST.Type as T

7+import qualified AST.Variable as Var

78import Language.ECMAScript3.Syntax

89

910data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

@@ -14,64 +15,71 @@ check x jsType continue =

1415 CondExpr () (jsFold OpLOr checks x) continue throw

1516 where

1617 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

1819 msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

1920 checks = case jsType of

2021 JSNumber -> [typeof "number"]

2122 JSBoolean -> [typeof "boolean"]

2223 JSString -> [typeof "string", instanceof "String"]

23− JSArray -> [(obj "_U.isJSArray" <|)]

24+ JSArray -> [(obj ["_U","isJSArray"] <|)]

2425 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

2526

26−incoming :: Type -> Expression ()

27+incoming :: CanonicalType -> Expression ()

2728incoming tipe =

2829 case tipe of

29− Data "Signal.Signal" [t] ->

30− obj "Native.Ports.incomingSignal" <| incoming t

30+ Aliased _ t -> incoming t

31+

32+ App (Type v) [t]

33+ | Var.isSignal v -> V.value "Native.Ports" "incomingSignal" <| incoming t

34+

3135 _ -> ["v"] ==> inc tipe (ref "v")

3236

33−inc :: Type -> Expression () -> Expression ()

37+inc :: CanonicalType -> Expression () -> Expression ()

3438inc tipe x =

3539 case tipe of

3640 Lambda _ _ -> error "functions should not be allowed through input ports"

3741 Var _ -> error "type variables should not be allowed through input ports"

38−

39− Data "Json.Value" [] ->

40− obj "Native.Json.fromJS" <| x

41−

42− Data ctor []

43− | ctor == "Int" -> from JSNumber

44− | ctor == "Float" -> from JSNumber

45− | ctor == "Bool" -> from JSBoolean

46− | ctor == "String" -> from JSString

42+ Aliased _ t ->

43+ inc t x

44+

45+ Type (Var.Canonical Var.BuiltIn name)

46+ | name == "Int" -> from JSNumber

47+ | name == "Float" -> from JSNumber

48+ | name == "Bool" -> from JSBoolean

49+ | name == "String" -> from JSString

4750 where

4851 from checks = check x checks x

4952

50− Data ctor [t]

51− | ctor == "Maybe.Maybe" ->

52− CondExpr () (equal x (NullLit ()))

53− (obj "Maybe.Nothing")

54− (obj "Maybe.Just" <| inc t x)

53+ Type name

54+ | Var.isJson name -> V.value "Native.Json" "fromJS" <| x

55+ | otherwise -> error "bad type got to incoming port generation code"

5556

56− | ctor == "_List" ->

57− check x JSArray (obj "_L.fromArray" <| array)

57+ App f args ->

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)

5863

59− | ctor == "Array.Array" ->

60− check x JSArray (obj "_A.fromJSArray" <| array)

64+ | Var.isList name -> check x JSArray (obj ["_L","fromArray"] <| array)

6165

62− where

63− array = DotRef () x (var "map") <| incoming t

66+ | Var.isArray name -> check x JSArray (obj ["_A","fromJSArray"] <| array)

67+ where

68+ array = DotRef () x (var "map") <| incoming t

6469

65− Data ctor ts

66− | Help.isTuple ctor -> check x JSArray tuple

67− where

68− tuple = ObjectLit () $ (prop "ctor", string ctor) : values

69− values = zipWith convert [0..] ts

70− convert n t = ( prop ('_':show n)

71− , inc t (BracketRef () x (IntLit () n)))

70+ Type name : ts

71+ | Var.isTuple name -> check x JSArray tuple

72+ where

73+ tuple = ObjectLit () $ (prop "ctor", ctor) : values

74+

75+ ctor = string ("_Tuple" ++ show (length ts))

76+ values = zipWith convert [0..] ts

7277

73− Data _ _ ->

74− error "bad ADT got to incoming port generation code"

78+ convert n t = ( prop ('_':show n)

79+ , inc t (BracketRef () x (IntLit () n))

80+ )

81+

82+ _ -> error "bad ADT got to incoming port generation code"

7583

7684 Record _ (Just _) ->

7785 error "bad record got to incoming port generation code"

@@ -83,15 +91,21 @@ inc tipe x =

8391 keys = map convert fields

8492 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

8593

94+outgoing :: CanonicalType -> Expression ()

8695outgoing tipe =

8796 case tipe of

88− Data "Signal.Signal" [t] ->

89− obj "Native.Ports.outgoingSignal" <| outgoing t

97+ Aliased _ t -> outgoing t

98+

99+ App (Type v) [t]

100+ | Var.isSignal v -> V.value "Native.Ports" "outgoingSignal" <| outgoing t

101+

90102 _ -> ["v"] ==> out tipe (ref "v")

91103

92−out :: Type -> Expression () -> Expression ()

104+out :: CanonicalType -> Expression () -> Expression ()

93105out tipe x =

94106 case tipe of

107+ Aliased _ t -> out t x

108+

95109 Lambda _ _

96110 | numArgs > 1 && numArgs < 10 ->

97111 func (ref ('A':show numArgs) `call` (x:values))

@@ -107,30 +121,34 @@ out tipe x =

107121 ]

108122

109123 Var _ -> error "type variables should not be allowed through input ports"

110− Data ctor []

111− | ctor `elem` ["Int","Float","Bool","String"] -> x

112− | ctor == "Json.Value" ->

113− obj "Native.Json.toJS" <| x

114−

115− Data ctor [t]

116− | ctor == "Maybe.Maybe" ->

117− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

118− (NullLit ())

119− (out t (DotRef () x (var "_0")))

120−

121− | ctor == "_List" ->

122− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

123−

124− | ctor == "Array.Array" ->

125− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

126−

127− Data ctor ts

128− | Help.isTuple ctor ->

129− let convert n t = out t $ DotRef () x $ var ('_':show n)

130− in ArrayLit () $ zipWith convert [0..] ts

131−

132− Data _ _ ->

133− error "bad ADT got to outgoing port generation code"

124+

125+ Type (Var.Canonical Var.BuiltIn name)

126+ | name `elem` ["Int","Float","Bool","String"] -> x

127+

128+ Type name

129+ | Var.isJson name -> V.value "Native.Json" "toJS" <| x

130+ | otherwise -> error "bad type got to outgoing port generation code"

131+

132+ App f args ->

133+ case f : args of

134+ Type name : [t]

135+ | Var.isMaybe name ->

136+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

137+ (NullLit ())

138+ (out t (DotRef () x (var "_0")))

139+

140+ | Var.isArray name ->

141+ DotRef () (obj ["_A","toJSArray"] <| x) (var "map") <| outgoing t

142+

143+ | Var.isList name ->

144+ DotRef () (obj ["_L","toArray"] <| x) (var "map") <| outgoing t

145+

146+ Type name : ts

147+ | Var.isTuple name ->

148+ let convert n t = out t $ DotRef () x $ var ('_':show n)

149+ in ArrayLit () $ zipWith convert [0..] ts

150+

151+ _ -> error "bad ADT got to outgoing port generation code"

134152

135153 Record _ (Just _) ->

136154 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

55import qualified Control.Exception as E

66import System.Exit

77import System.IO

8−import SourceSyntax.Module

8+import AST.Module as Module

9+import qualified AST.Variable as Var

910import qualified Build.Interface as Interface

1011import Build.Utils (getDataFile)

1112

12−add :: Bool -> Module def -> Module def

13−add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls

13+add :: Bool -> Module exs body -> Module exs body

14+add noPrelude (Module name path exs ims decls) =

15+ Module name path exs (customIms ++ ims) decls

1416 where

1517 customIms = if noPrelude then [] else concatMap addModule prelude

1618

@@ -20,15 +22,26 @@ add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) d

2022 Just _ -> []

2123

2224prelude :: [(String, ImportMethod)]

23−prelude = string ++ text ++ map (\n -> (n, Hiding [])) modules

25+prelude = string : text : maybe : map (\n -> (n, Module.open)) modules

2426 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"

2828 , "Graphics.Element", "Graphics.Collage"

2929 , "Native.Ports", "Native.Json"

3030 ]

3131

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+

3245interfaces :: Bool -> IO Interfaces

3346interfaces noPrelude =

3447 if noPrelude

@@ -42,14 +55,14 @@ safeReadDocs name =

4255 hPutStrLn stderr $ unlines $

4356 [ "Error reading types for standard library from file " ++ name

4457 , " 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"

4659 , " Elm and your OS." ]

4760 exitFailure

4861

4962readDocs :: FilePath -> IO Interfaces

5063readDocs filePath = do

5164 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

5366 Left err -> do

5467 hPutStrLn stderr err

5568 exitFailure

compiler/Parse/Binop.hs+19−17

@@ -5,9 +5,11 @@ import Control.Applicative ((<$>))

55import qualified Data.List as List

66import qualified Data.Map as Map

77

8−import SourceSyntax.Annotation (merge)

9−import qualified SourceSyntax.Expression as E

10−import SourceSyntax.Declaration (Assoc(..))

8+import AST.Annotation (merge)

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

1113import Text.Parsec

1214import Parse.Helpers

1315

@@ -17,13 +19,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

1719opAssoc :: OpTable -> String -> Assoc

1820opAssoc table op = snd $ Map.findWithDefault (9,L) op table

1921

20−hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool

22+hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool

2123hasLevel table n (op,_) = opLevel table op == n

2224

23−binops :: IParser E.ParseExpr

24− -> IParser E.ParseExpr

25+binops :: IParser Source.Expr

26+ -> IParser Source.Expr

2527 -> IParser String

26− -> IParser E.ParseExpr

28+ -> IParser Source.Expr

2729binops term last anyOp =

2830 do e <- term

2931 table <- getState

@@ -39,9 +41,9 @@ binops term last anyOp =

3941

4042split :: OpTable

4143 -> Int

42− -> E.ParseExpr

43− -> [(String, E.ParseExpr)]

44− -> IParser E.ParseExpr

44+ -> Source.Expr

45+ -> [(String, Source.Expr)]

46+ -> IParser Source.Expr

4547split _ _ e [] = return e

4648split table n e eops = do

4749 assoc <- getAssoc table n eops

@@ -50,26 +52,26 @@ split table n e eops = do

5052 case assoc of R -> joinR es ops

5153 _ -> joinL es ops

5254

53−splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]

54− -> [IParser E.ParseExpr]

55+splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)]

56+ -> [IParser Source.Expr]

5557splitLevel table n e eops =

5658 case break (hasLevel table n) eops of

5759 (lops, (_op,e'):rops) ->

5860 split table (n+1) e lops : splitLevel table n e' rops

5961 (lops, []) -> [ split table (n+1) e lops ]

6062

61−joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

63+joinL :: [Source.Expr] -> [String] -> IParser Source.Expr

6264joinL [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

6466joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

6567

66−joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr

68+joinR :: [Source.Expr] -> [String] -> IParser Source.Expr

6769joinR [e] [] = return e

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

7072joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

7173

72−getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc

74+getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc

7375getAssoc table n eops

7476 | all (==L) assocs = return L

7577 | all (==R) assocs = return R

compiler/Parse/Declaration.hs+7−8

@@ -7,16 +7,15 @@ import Text.Parsec hiding (newline,spaces)

77import Parse.Helpers

88import qualified Parse.Expression as Expr

99import qualified Parse.Type as Type

10−import qualified SourceSyntax.Declaration as D

10+import qualified AST.Declaration as D

1111

12−

13−declaration :: IParser D.ParseDeclaration

12+declaration :: IParser D.SourceDecl

1413declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

1514

16−definition :: IParser D.ParseDeclaration

15+definition :: IParser D.SourceDecl

1716definition = D.Definition <$> Expr.def

1817

19−alias :: IParser D.ParseDeclaration

18+alias :: IParser D.SourceDecl

2019alias = do

2120 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

2221 forcedWS

@@ -26,7 +25,7 @@ alias = do

2625 tipe <- Type.expr

2726 return (D.TypeAlias name args tipe)

2827

29−datatype :: IParser D.ParseDeclaration

28+datatype :: IParser D.SourceDecl

3029datatype = do

3130 reserved "data" <?> "datatype definition (data T = A | B | ...)"

3231 forcedWS

@@ -37,7 +36,7 @@ datatype = do

3736 return $ D.Datatype name args tcs

3837

3938

40−infixDecl :: IParser D.ParseDeclaration

39+infixDecl :: IParser D.SourceDecl

4140infixDecl = do

4241 assoc <- choice [ reserved "infixl" >> return D.L

4342 , reserved "infix" >> return D.N

@@ -48,7 +47,7 @@ infixDecl = do

4847 D.Fixity assoc (read [n]) <$> anyOp

4948

5049

51−port :: IParser D.ParseDeclaration

50+port :: IParser D.SourceDecl

5251port =

5352 do try (reserved "port")

5453 whitespace

compiler/Parse/Expression.hs+31−29

@@ -11,39 +11,41 @@ import Parse.Literal

1111import qualified Parse.Pattern as Pattern

1212import qualified Parse.Type as Type

1313

14−import SourceSyntax.Annotation as Annotation

15−import qualified SourceSyntax.Pattern as P

16−import qualified SourceSyntax.Literal as L

17−import SourceSyntax.Expression

14+import AST.Annotation as Annotation

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

19+import qualified AST.Variable as Var

1820

1921

2022-------- Basic Terms --------

2123

22−varTerm :: IParser ParseExpr'

24+varTerm :: IParser Source.Expr'

2325varTerm = toVar <$> var <?> "variable"

2426

25−toVar :: String -> ParseExpr'

27+toVar :: String -> Source.Expr'

2628toVar v = case v of "True" -> Literal (L.Boolean True)

2729 "False" -> Literal (L.Boolean False)

2830 _ -> rawVar v

2931

30−accessor :: IParser ParseExpr'

32+accessor :: IParser Source.Expr'

3133accessor = do

3234 (start, lbl, end) <- located (try (string "." >> rLabel))

3335 let loc e = Annotation.at start end e

3436 return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))

3537

36−negative :: IParser ParseExpr'

38+negative :: IParser Source.Expr'

3739negative = do

3840 (start, nTerm, end) <-

3941 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

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

4244

4345

4446-------- Complex Terms --------

4547

46−listTerm :: IParser ParseExpr'

48+listTerm :: IParser Source.Expr'

4749listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> commaSep expr)

4850 where

4951 range = do

@@ -73,14 +75,14 @@ listTerm = markdown' <|> shader' <|> braces (try range <|> ExplicitList <$> comm

7375 string "}}"

7476 return (span uid (length exprs), exprs ++ [e])

7577

76−parensTerm :: IParser ParseExpr

78+parensTerm :: IParser Source.Expr

7779parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

7880 where

7981 opFn = do

8082 (start, op, end) <- located anyOp

8183 let loc = Annotation.at start end

8284 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"))

8486

8587 tupleFn = do

8688 let comma = char ',' <?> "comma ','"

@@ -96,7 +98,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

9698 [e] -> e

9799 _ -> Annotation.at start end (tuple es)

98100

99−recordTerm :: IParser ParseExpr

101+recordTerm :: IParser Source.Expr

100102recordTerm = brackets $ choice [ misc, addLocation record ]

101103 where

102104 field = do

@@ -130,14 +132,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

130132 Nothing -> try (insert record) <|> try (modify record)

131133

132134

133−term :: IParser ParseExpr

135+term :: IParser Source.Expr

134136term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

135137 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

136138 <?> "basic term (4, x, 'c', etc.)"

137139

138140-------- Applications --------

139141

140−appExpr :: IParser ParseExpr

142+appExpr :: IParser Source.Expr

141143appExpr = do

142144 t <- term

143145 ts <- constrainedSpacePrefix term $ \str ->

@@ -148,12 +150,12 @@ appExpr = do

148150

149151-------- Normal Expressions --------

150152

151−binaryExpr :: IParser ParseExpr

153+binaryExpr :: IParser Source.Expr

152154binaryExpr = binops appExpr lastExpr anyOp

153155 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

154156 <|> lambdaExpr

155157

156−ifExpr :: IParser ParseExpr'

158+ifExpr :: IParser Source.Expr'

157159ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

158160 where

159161 normal = do

@@ -169,7 +171,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

169171 b <- expr ; padded arrow

170172 (,) b <$> expr

171173

172−lambdaExpr :: IParser ParseExpr

174+lambdaExpr :: IParser Source.Expr

173175lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

174176 whitespace

175177 args <- spaceSep1 Pattern.term

@@ -177,17 +179,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

177179 body <- expr

178180 return (makeFunction args body)

179181

180−defSet :: IParser [ParseDef]

182+defSet :: IParser [Source.Def]

181183defSet = block (do d <- def ; whitespace ; return d)

182184

183−letExpr :: IParser ParseExpr'

185+letExpr :: IParser Source.Expr'

184186letExpr = do

185187 reserved "let" ; whitespace

186188 defs <- defSet

187189 padded (reserved "in")

188190 Let defs <$> expr

189191

190−caseExpr :: IParser ParseExpr'

192+caseExpr :: IParser Source.Expr'

191193caseExpr = do

192194 reserved "case"; e <- padded expr; reserved "of"; whitespace

193195 Case e <$> (with <|> without)

@@ -197,13 +199,13 @@ caseExpr = do

197199 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

198200 without = block (do c <- case_ ; whitespace ; return c)

199201

200−expr :: IParser ParseExpr

202+expr :: IParser Source.Expr

201203expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

202204 <|> lambdaExpr

203205 <|> binaryExpr

204206 <?> "an expression"

205207

206−defStart :: IParser [P.Pattern]

208+defStart :: IParser [P.RawPattern]

207209defStart =

208210 choice [ do p1 <- try Pattern.term

209211 infics p1 <|> func p1

@@ -223,24 +225,24 @@ defStart =

223225 return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]

224226 else [ P.Var (o:p), p1, p2 ]

225227

226−makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr

228+makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr

227229makeFunction args body@(A ann _) =

228230 foldr (\arg body' -> A ann $ Lambda arg body') body args

229231

230−definition :: IParser ParseDef

232+definition :: IParser Source.Def

231233definition = withPos $ do

232234 (name:args) <- defStart

233235 padded equals

234236 body <- expr

235− return . Def name $ makeFunction args body

237+ return . Source.Definition name $ makeFunction args body

236238

237−typeAnnotation :: IParser ParseDef

238−typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

239+typeAnnotation :: IParser Source.Def

240+typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr

239241 where

240242 start = do

241243 v <- lowVar <|> parens symOp

242244 padded hasType

243245 return v

244246

245−def :: IParser ParseDef

247+def :: IParser Source.Def

246248def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+11−28

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

66import Control.Monad

77import Control.Monad.State

88import Data.Char (isUpper)

9−import qualified Data.Set as Set

109import qualified Data.Map as Map

1110import qualified Language.GLSL.Parser as GLP

1211import Language.GLSL.Syntax as GLS

@@ -14,13 +13,14 @@ import Text.Parsec hiding (newline,spaces,State)

1413import Text.Parsec.Indent

1514import qualified Text.Parsec.Token as T

1615

17−import SourceSyntax.Annotation as Annotation

18−import SourceSyntax.Declaration (Assoc)

19−import SourceSyntax.Expression

20−import SourceSyntax.Helpers as Help

21−import SourceSyntax.Literal as Literal

22−import SourceSyntax.PrettyPrint

23−import SourceSyntax.Variable as Variable

16+import AST.Annotation as Annotation

17+import AST.Declaration (Assoc)

18+import AST.Expression.General

19+import qualified AST.Expression.Source as Source

20+import AST.Helpers as Help

21+import AST.Literal as Literal

22+import AST.PrettyPrint

23+import qualified AST.Variable as Variable

2424

2525reserveds = [ "if", "then", "else"

2626 , "case", "of"

@@ -29,25 +29,8 @@ reserveds = [ "if", "then", "else"

2929 , "module", "where"

3030 , "import", "as", "hiding", "open"

3131 , "export", "foreign"

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− ]

32+ , "deriving", "port"

33+ ]

5134

5235expecting = flip (<?>)

5336

@@ -200,7 +183,7 @@ located p = do

200183 end <- getPosition

201184 return (start, e, end)

202185

203−accessible :: IParser ParseExpr -> IParser ParseExpr

186+accessible :: IParser Source.Expr -> IParser Source.Expr

204187accessible expr = do

205188 start <- getPosition

206189 ce@(A _ e) <- expr

compiler/Parse/Literal.hs+1−1

@@ -4,7 +4,7 @@ module Parse.Literal (literal) where

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

55import Text.Parsec hiding (newline,spaces)

66import Parse.Helpers

7−import SourceSyntax.Literal

7+import AST.Literal

88

99literal :: IParser Literal

1010literal = num <|> (Str <$> str) <|> (Chr <$> chr) <?> "literal"

compiler/Parse/Module.hs+31−14

@@ -5,10 +5,8 @@ import Data.List (intercalate)

55import Text.Parsec hiding (newline,spaces)

66

77import Parse.Helpers

8−import SourceSyntax.Module (ImportMethod(..), Imports)

9−

10−varList :: IParser [String]

11−varList = commaSep1 (var <|> parens symOp)

8+import AST.Module (ImportMethod(..))

9+import AST.Variable (Listing(..), Value(..), openListing)

1210

1311getModuleName :: String -> Maybe String

1412getModuleName source =

@@ -21,18 +19,18 @@ getModuleName source =

2119 (names, _) <- moduleDef

2220 return (intercalate "." names)

2321

24−moduleDef :: IParser ([String], [String])

22+moduleDef :: IParser ([String], Listing Value)

2523moduleDef = do

2624 try (reserved "module")

2725 whitespace

2826 names <- dotSep1 capVar <?> "name of module"

2927 whitespace

30− exports <- option [] (parens varList)

28+ exports <- option (Listing [] True) (listing value)

3129 whitespace <?> "reserved word 'where'"

3230 reserved "where"

3331 return (names, exports)

3432

35−imports :: IParser Imports

33+imports :: IParser [(String, ImportMethod)]

3634imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))

3735

3836import' :: IParser (String, ImportMethod)

@@ -43,17 +41,36 @@ import' =

4341 (,) name <$> option (As name) method

4442 where

4543 method :: IParser ImportMethod

46− method = try $ do whitespace

47− as' <|> importing'

44+ method = as' <|> importing'

4845

4946 as' :: IParser ImportMethod

5047 as' = do

51− reserved "as"

48+ try (whitespace >> reserved "as")

5249 whitespace

5350 As <$> capVar <?> "alias for module"

5451

5552 importing' :: IParser ImportMethod

56− importing' =

57− parens (choice [ const (Hiding []) <$> string ".."

58− , Importing <$> varList

59− ] <?> "listing of imported values (x,y,z)")

53+ importing' = Open <$> listing value

54+

55+listing :: IParser a -> IParser (Listing a)

56+listing item =

57+ do try (whitespace >> char '(')

58+ whitespace

59+ listing <- choice [ const openListing <$> string ".."

60+ , Listing <$> commaSep1 item <*> return False

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

77import Text.Parsec hiding (newline,spaces)

88import qualified Text.PrettyPrint as P

99

10−import qualified SourceSyntax.Declaration as D

11−import qualified SourceSyntax.Module as M

10+import qualified AST.Declaration as D

11+import qualified AST.Module as M

12+import qualified AST.Variable as Var

1213import Parse.Helpers

1314import Parse.Declaration (infixDecl)

1415import Parse.Module

@@ -22,21 +23,24 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

2223decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

2324 (d:) <$> many freshDef

2425

25−program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program :: OpTable -> String -> Either [P.Doc] M.ValidModule

2627program table src =

27− do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

28− decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29− return $ M.Module names exs ims decls

28+ do (M.Module names filePath exs ims parseDecls) <-

29+ setupParserWithTable table programParser src

30+ decls <-

31+ either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

32+ return $ M.Module names filePath exs ims decls

3033

31−programParser :: IParser (M.Module D.ParseDeclaration)

34+programParser :: IParser M.SourceModule

3235programParser =

3336 do optional freshLine

34− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

37+ (names,exports) <-

38+ option (["Main"], Var.openListing) (moduleDef `followedBy` freshLine)

3539 is <- (do try (lookAhead $ reserved "import")

3640 imports `followedBy` freshLine) <|> return []

3741 declarations <- decls

3842 optional freshLine ; optional spaces ; eof

39− return $ M.Module names exports is declarations

43+ return $ M.Module names "" exports is declarations

4044

4145dependencies :: String -> Either [P.Doc] (String, [String])

4246dependencies =

compiler/Parse/Pattern.hs+13−12

@@ -8,54 +8,55 @@ import Text.Parsec hiding (newline,spaces,State)

88

99import Parse.Helpers

1010import Parse.Literal

11−import SourceSyntax.Literal

12−import qualified SourceSyntax.Pattern as P

11+import AST.Literal

12+import qualified AST.Pattern as P

13+import qualified AST.Variable as Var

1314

14−basic :: IParser P.Pattern

15+basic :: IParser P.RawPattern

1516basic = choice

1617 [ char '_' >> return P.Anything

1718 , do v <- var

1819 return $ case v of

1920 "True" -> P.Literal (Boolean True)

2021 "False" -> P.Literal (Boolean False)

21− c:_ | isUpper c -> P.Data v []

22+ c:_ | isUpper c -> P.Data (Var.Raw v) []

2223 _ -> P.Var v

2324 , P.Literal <$> literal

2425 ]

2526

26−asPattern :: P.Pattern -> IParser P.Pattern

27+asPattern :: P.RawPattern -> IParser P.RawPattern

2728asPattern pattern = do

2829 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))

2930 return $ case var of

3031 Just v -> P.Alias v pattern

3132 Nothing -> pattern

3233

33−record :: IParser P.Pattern

34+record :: IParser P.RawPattern

3435record = P.Record <$> brackets (commaSep1 lowVar)

3536

36−tuple :: IParser P.Pattern

37+tuple :: IParser P.RawPattern

3738tuple = do

3839 ps <- parens (commaSep expr)

3940 return $ case ps of

4041 [p] -> p

4142 _ -> P.tuple ps

4243

43−list :: IParser P.Pattern

44+list :: IParser P.RawPattern

4445list = P.list <$> braces (commaSep expr)

4546

46−term :: IParser P.Pattern

47+term :: IParser P.RawPattern

4748term =

4849 (choice [ record, tuple, list, basic ]) <?> "pattern"

4950

50−patternConstructor :: IParser P.Pattern

51+patternConstructor :: IParser P.RawPattern

5152patternConstructor = do

5253 v <- List.intercalate "." <$> dotSep1 capVar

5354 case v of

5455 "True" -> return $ P.Literal (Boolean True)

5556 "False" -> return $ P.Literal (Boolean False)

56− _ -> P.Data v <$> spacePrefix term

57+ _ -> P.Data (Var.Raw v) <$> spacePrefix term

5758

58−expr :: IParser P.Pattern

59+expr :: IParser P.RawPattern

5960expr = do

6061 patterns <- consSep1 (patternConstructor <|> term)

6162 asPattern (foldr1 P.cons patterns) <?> "pattern"

compiler/Parse/Type.hs+21−17

@@ -5,22 +5,23 @@ import Control.Applicative ((<$>),(<*>),(<*))

55import Data.List (intercalate)

66import Text.Parsec

77

8−import SourceSyntax.Type as T

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

910import Parse.Helpers

1011

11−tvar :: IParser T.Type

12+tvar :: IParser T.RawType

1213tvar = T.Var <$> lowVar <?> "type variable"

1314

14−list :: IParser T.Type

15−list = listOf <$> braces expr

15+list :: IParser T.RawType

16+list = T.listOf <$> braces expr

1617

17−tuple :: IParser T.Type

18+tuple :: IParser T.RawType

1819tuple = do ts <- parens (commaSep expr)

1920 return $ case ts of

2021 [t] -> t

21− _ -> tupleOf ts

22+ _ -> T.tupleOf ts

2223

23−record :: IParser T.Type

24+record :: IParser T.RawType

2425record =

2526 do char '{' ; whitespace

2627 rcrd <- extended <|> normal

@@ -33,7 +34,7 @@ record =

3334 extended = do

3435 ext <- try (lowVar <* (whitespace >> string "|"))

3536 whitespace

36− flip T.Record (Just ext) <$> commaSep1 field

37+ flip T.Record (Just (T.Var ext)) <$> commaSep1 field

3738

3839 field = do

3940 lbl <- rLabel

@@ -43,25 +44,28 @@ record =

4344capTypeVar :: IParser String

4445capTypeVar = intercalate "." <$> dotSep1 capVar

4546

46−constructor0 :: IParser T.Type

47+constructor0 :: IParser T.RawType

4748constructor0 =

4849 do name <- capTypeVar

49− return (T.Data name [])

50+ return (T.Type (Var.Raw name))

5051

51−term :: IParser T.Type

52+term :: IParser T.RawType

5253term = list <|> tuple <|> record <|> tvar <|> constructor0

5354

54−app :: IParser T.Type

55+app :: IParser T.RawType

5556app =

56− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

57+ do f <- constructor0 <|> try tupleCtor <?> "type constructor"

5758 args <- spacePrefix term

58− return (T.Data name args)

59+ return $ case args of

60+ [] -> f

61+ _ -> T.App f args

5962 where

6063 tupleCtor = do

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

6367

64−expr :: IParser T.Type

68+expr :: IParser T.RawType

6569expr =

6670 do t1 <- app <|> term

6771 arr <- optionMaybe $ try (whitespace >> arrow)

@@ -69,6 +73,6 @@ expr =

6973 Just _ -> T.Lambda t1 <$> (whitespace >> expr)

7074 Nothing -> return t1

7175

72−constructor :: IParser (String, [T.Type])

76+constructor :: IParser (String, [T.RawType])

7377constructor = (,) <$> (capTypeVar <?> "another type constructor")

7478 <*> 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 #-}

2−module Transform.Canonicalize (interface, metadataModule) where

1+{-# OPTIONS_GHC -W #-}

2+module Transform.Canonicalize (module', filterExports) where

33

4−import Control.Arrow ((***))

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

6−import Control.Monad.Identity

7−import qualified Data.Either as Either

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

5+import Control.Monad.Error (runErrorT, throwError)

6+import Control.Monad.State (runState)

87import qualified Data.List as List

98import qualified Data.Map as Map

109import qualified Data.Set as Set

1110import qualified Data.Traversable as T

12−import SourceSyntax.Annotation as A

13−import SourceSyntax.Expression

14−import SourceSyntax.Module

15−import SourceSyntax.PrettyPrint (pretty)

16−import qualified SourceSyntax.Pattern as P

17−import qualified SourceSyntax.Type as Type

18−import qualified SourceSyntax.Variable as Var

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

20+import qualified AST.Annotation as A

21+import qualified AST.Declaration as D

22+import AST.PrettyPrint (pretty, commaSep)

23+import qualified AST.Pattern as P

1924import Text.PrettyPrint as P

2025

21−interface :: String -> ModuleInterface -> ModuleInterface

22−interface moduleName iface =

23− ModuleInterface

24− { iVersion = iVersion iface

25− , iTypes = Map.mapKeys prefix (Map.map renameType' (iTypes iface))

26− , iImports = iImports iface

27− , iAdts = map (both prefix renameCtors) (iAdts iface)

28− , iAliases = map (both prefix renameType') (iAliases iface)

29− , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

30− , iPorts = iPorts iface

31− }

26+import Transform.Canonicalize.Environment as Env

27+import qualified Transform.Canonicalize.Setup as Setup

28+import qualified Transform.Canonicalize.Type as Canonicalize

29+import qualified Transform.Canonicalize.Variable as Canonicalize

30+import qualified Transform.SortDefinitions as Transform

31+import qualified Transform.Declaration as Transform

32+

33+module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule

34+module' interfaces modul =

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

52+ }

3253 where

33− both f g (a,b,c) = (f a, b, g c)

34− prefix name = moduleName ++ "." ++ name

35−

36− pair name = (name, moduleName ++ "." ++ name)

37− canon (name,_,_) = pair name

38− canons = Map.fromList $ concat

39− [ map canon (iAdts iface), map canon (iAliases iface) ]

40−

41− renameCtors ctors =

42− map (prefix *** map renameType') ctors

43− renameType' =

44− runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

45−

46−renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

47−renameType renamer tipe =

48− let rnm = renameType renamer in

49− case tipe of

50− Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

51− Type.Var _ -> return tipe

52− Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

53− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

54− where rnm' (f,t) = (,) f <$> rnm t

55−

56−metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

57−metadataModule ifaces modul =

58− do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

59− [] -> Right ()

60− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ++

61− "\n You may need to compile with the --make flag to detect modules you have written."

62− ]

63− program' <- rename initialEnv (program modul)

64− aliases' <- mapM (three3 renameType') (aliases modul)

65− datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)

66− return $ modul { program = program'

67− , aliases = aliases'

68− , datatypes = datatypes' }

54+ locals :: [Var.Value]

55+ locals = concatMap declToValue decls

56+

57+ body :: [D.CanonicalDecl] -> Module.CanonicalBody

58+ body decls =

59+ Module.CanonicalBody

60+ { program =

61+ let expr = Transform.toExpr (Module.getName modul) decls

62+ in Transform.sortDefs (dummyLet expr)

63+ , types = Map.empty

64+ , datatypes =

65+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]

66+ , fixities =

67+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]

68+ , aliases =

69+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

70+ , ports =

71+ [ D.portName port | D.Port port <- decls ]

72+ }

73+

74+delist :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]

75+delist fullList (Var.Listing partial open)

76+ | open = return fullList

77+ | otherwise = go [] (List.sort fullList) (List.sort partial)

78+ where

79+ notFound xs =

80+ throwError [ P.text "Export Error: trying to export non-existent values:" <+>

81+ commaSep (map pretty xs)

82+ ]

83+

84+ go list full partial =

85+ case (full, partial) of

86+ (_, []) -> return list

87+ ([], _) -> notFound partial

88+ (x:xs, y:ys) ->

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)

69112 where

70− two2 f (a,b) = (,) a <$> f b

71− three3 f (a,b,c) = (,,) a b <$> f c

72− renameType' =

73− Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

74−

75− get1 (a,_,_) = a

76− canon (name, importMethod) =

77− let pair pre var = (pre ++ drop (length name + 1) var, var)

78− iface = ifaces Map.! name

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

107− Just v' -> return v'

108− Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg

113+ getValue :: Var.Value -> [(String, Type.CanonicalType)]

114+ getValue value =

115+ case value of

116+ Var.Value x -> get x

117+ Var.Alias x -> get x

118+ Var.ADT _ (Var.Listing ctors _) -> concatMap get ctors

119+

120+ get :: String -> [(String, Type.CanonicalType)]

121+ get x =

122+ case Map.lookup x types of

123+ Just t -> [(x,t)]

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

109157 where

110− matches = filter (List.isInfixOf v) (Map.keys env)

111− msg = if null matches then "" else

112− "\nClose matches include: " ++ List.intercalate ", " matches

113−

114−-- TODO: Var.Raw -> Var.Canonical

115−rename :: Env -> Expr -> Either [Doc] Expr

116−rename env (A ann expr) =

117− let rnm = rename env

118− throw err = Left [ P.vcat [ P.text "Error" <+> pretty ann <> P.colon

119− , P.text err

120− ]

121− ]

122− format = Either.either throw return

123− renameType' environ = renameType (format . replace "variable" environ)

158+ canonicalize' (ctor,args) =

159+ (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args

160+

161+ D.TypeAlias name tvars expanded ->

162+ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

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

181+expression env (A.A ann expr) =

182+ let go = expression env

183+ tipe' environ = format . Canonicalize.tipe environ

184+ throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon

185+ , P.text err ]

186+ format = Env.onError throw

124187 in

125− A ann <$>

188+ A.A ann <$>

126189 case expr of

127− Literal _ -> return expr

190+ Literal lit -> return (Literal lit)

128191

129− Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

192+ Range e1 e2 -> Range <$> go e1 <*> go e2

130193

131− Access e x -> Access <$> rnm e <*> return x

194+ Access e x -> Access <$> go e <*> return x

132195

133− Remove e x -> flip Remove x <$> rnm e

196+ Remove e x -> flip Remove x <$> go e

134197

135− Insert e x v -> flip Insert x <$> rnm e <*> rnm v

198+ Insert e x v -> flip Insert x <$> go e <*> go v

136199

137200 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

139202

140− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

203+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs

141204

142− Binop op e1 e2 ->

143− do op' <- format (replace "variable" env op)

144− Binop op' <$> rnm e1 <*> rnm e2

205+ Binop (Var.Raw op) e1 e2 ->

206+ do op' <- format (Canonicalize.variable env op)

207+ Binop op' <$> go e1 <*> go e2

145208

146− Lambda pattern e ->

147− let env' = extend env pattern in

148− Lambda <$> format (renamePattern env' pattern) <*> rename env' e

209+ Lambda p e ->

210+ let env' = update p env in

211+ Lambda <$> format (pattern env' p) <*> expression env' e

149212

150− App e1 e2 -> App <$> rnm e1 <*> rnm e2

213+ App e1 e2 -> App <$> go e1 <*> go e2

151214

152− MultiIf ps -> MultiIf <$> mapM grnm ps

153− where grnm (b,e) = (,) <$> rnm b <*> rnm e

215+ MultiIf ps -> MultiIf <$> mapM go' ps

216+ where go' (b,e) = (,) <$> go b <*> go e

154217

155− Let defs e -> Let <$> mapM rename' defs <*> rename env' e

218+ Let defs e -> Let <$> mapM rename' defs <*> expression env' e

156219 where

157− env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

158− rename' (Definition p body mtipe) =

159− Definition <$> format (renamePattern env' p)

160− <*> rename env' body

161− <*> T.traverse (renameType' env') mtipe

220+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs

221+ rename' (Valid.Definition p body mtipe) =

222+ Canonical.Definition

223+ <$> format (pattern env' p)

224+ <*> expression env' body

225+ <*> T.traverse (tipe' env') mtipe

162226

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)

165228

166− Data name es -> Data name <$> mapM rnm es

229+ Data name es -> Data name <$> mapM go es

167230

168− ExplicitList es -> ExplicitList <$> mapM rnm es

231+ ExplicitList es -> ExplicitList <$> mapM go es

169232

170− Case e cases -> Case <$> rnm e <*> mapM branch cases

233+ Case e cases -> Case <$> go e <*> mapM branch cases

171234 where

172− branch (pattern,b) = (,) <$> format (renamePattern env pattern)

173− <*> rename (extend env pattern) b

174−

175− Markdown uid md es -> Markdown uid md <$> mapM rnm es

176−

177− PortIn name st -> PortIn name <$> renameType' env st

178−

179− PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

180−

181− GLShader _ _ _ -> return expr

182−

183−renamePattern :: Env -> P.Pattern -> Either String P.Pattern

184−renamePattern env pattern =

185− case pattern of

186− P.Var _ -> return pattern

187− P.Literal _ -> return pattern

188− P.Record _ -> return pattern

189− P.Anything -> return pattern

190− P.Alias x p -> P.Alias x <$> renamePattern env p

191− P.Data name ps -> P.Data <$> replace "pattern" env name

192− <*> mapM (renamePattern env) ps

235+ branch (p,b) = (,) <$> format (pattern env p)

236+ <*> expression (update p env) b

237+

238+ Markdown uid md es ->

239+ do Env.uses "Text"

240+ Markdown uid md <$> mapM go es

241+

242+ PortIn name st -> PortIn name <$> tipe' env st

243+

244+ PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal

245+

246+ GLShader uid src tipe -> return (GLShader uid src tipe)

247+

248+pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern

249+pattern env ptrn =

250+ case ptrn of

251+ P.Var x -> return $ P.Var x

252+ P.Literal lit -> return $ P.Literal lit

253+ P.Record fs -> return $ P.Record fs

254+ P.Anything -> return P.Anything

255+ P.Alias x p -> P.Alias x <$> pattern env p

256+ P.Data (Var.Raw name) ps ->

257+ P.Data <$> Canonicalize.pvar env name

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

66import qualified Data.Maybe as Maybe

77import qualified Data.Set as Set

88

9−import qualified SourceSyntax.Expression as E

10−import qualified SourceSyntax.Declaration as D

11−import qualified SourceSyntax.Pattern as Pattern

12−import qualified SourceSyntax.Type as T

9+import qualified AST.Expression.Valid as Valid

10+import qualified AST.Declaration as D

11+import qualified AST.Pattern as Pattern

12+import qualified AST.Type as T

13+import qualified AST.Variable as Var

1314import qualified Transform.Expression as Expr

1415

15−import SourceSyntax.PrettyPrint

16+import AST.PrettyPrint

1617import Text.PrettyPrint as P

1718

1819

19−mistakes :: [D.Declaration] -> [Doc]

20+mistakes :: [D.ValidDecl] -> [Doc]

2021mistakes decls =

2122 concat [ infiniteTypeAliases decls

2223 , illFormedTypes decls

@@ -30,7 +31,7 @@ dupErr :: String -> String -> String

3031dupErr err x =

3132 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

3233

33−duplicates :: [D.Declaration] -> [String]

34+duplicates :: [D.ValidDecl] -> [String]

3435duplicates decls =

3536 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

3637 case mapM exprDups (portExprs ++ defExprs) of

@@ -41,7 +42,7 @@ duplicates decls =

4142 msg = dupErr "definition of"

4243

4344 (defPatterns, defExprs) =

44− unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45+ unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

4546

4647 (portNames, portExprs) =

4748 Arrow.second concat $ unzip $

@@ -50,17 +51,17 @@ duplicates decls =

5051 D.Out name expr _ -> (name, [expr])

5152 D.In name _ -> (name, [])

5253

53− exprDups :: E.Expr -> Either String E.Expr

54+ exprDups :: Valid.Expr -> Either String Valid.Expr

5455 exprDups expr = Expr.crawlLet defsDups expr

5556

56− defsDups :: [E.Def] -> Either String [E.Def]

57+ defsDups :: [Valid.Def] -> Either String [Valid.Def]

5758 defsDups defs =

58− let varsIn (E.Definition pattern _ _) = Pattern.boundVarList pattern in

59+ let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in

5960 case dups $ concatMap varsIn defs of

6061 [] -> Right defs

6162 name:_ -> Left name

6263

63−duplicateConstructors :: [D.Declaration] -> [String]

64+duplicateConstructors :: [D.ValidDecl] -> [String]

6465duplicateConstructors decls =

6566 map (dupErr "definition of type constructor") (dups typeCtors) ++

6667 map (dupErr "definition of data constructor") (dups dataCtors)

@@ -68,7 +69,7 @@ duplicateConstructors decls =

6869 typeCtors = [ name | D.Datatype name _ _ <- decls ]

6970 dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]

7071

71−illFormedTypes :: [D.Declaration] -> [Doc]

72+illFormedTypes :: [D.ValidDecl] -> [Doc]

7273illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

7374 where

7475 aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ]

@@ -78,9 +79,11 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

7879 case tipe of

7980 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

8081 T.Var x -> Set.singleton x

81− T.Data _ ts -> Set.unions (map freeVars ts)

82+ T.Type _ -> Set.empty

83+ T.App t ts -> Set.unions (map freeVars (t:ts))

8284 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

8487

8588 undeclared tvars tipes = Set.difference used declared

8689 where

@@ -113,20 +116,23 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

113116 quote tvar = "'" ++ tvar ++ "'"

114117

115118

116−infiniteTypeAliases :: [D.Declaration] -> [Doc]

119+infiniteTypeAliases :: [D.ValidDecl] -> [Doc]

117120infiniteTypeAliases decls =

118121 [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls

119122 , infiniteType name tipe ]

120123 where

124+ infiniteType :: String -> T.Type Var.Raw -> Bool

121125 infiniteType name tipe =

122126 let infinite = infiniteType name in

123127 case tipe of

124128 T.Lambda a b -> infinite a || infinite b

125129 T.Var _ -> False

126− T.Data name' ts -> name == name' || any infinite ts

130+ T.Type (Var.Raw name') -> name == name'

131+ T.App t ts -> any infinite (t:ts)

127132 T.Record fields _ -> any (infinite . snd) fields

133+ T.Aliased _ t -> infinite t

128134

129− indented :: D.Declaration -> Doc

135+ indented :: D.ValidDecl -> Doc

130136 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

131137

132138 report name args tipe =

compiler/Transform/Declaration.hs+89−24

@@ -1,16 +1,23 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration where

2+module Transform.Declaration (combineAnnotations, toExpr) where

33

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

5−import qualified SourceSyntax.Pattern as P

6−import SourceSyntax.Expression as E

7−import SourceSyntax.Declaration as D

5+

6+import qualified AST.Annotation as A

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

815

916import qualified Transform.Expression as Expr

1017import qualified Transform.Definition as Def

1118

1219

13−combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

20+combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

1421combineAnnotations = go

1522 where

1623 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -23,41 +30,99 @@ combineAnnotations = go

2330 -- simple cases, pass them through with no changes

2431 [] -> return []

2532

26− Datatype name tvars ctors : rest ->

27− (:) (Datatype name tvars ctors) <$> go rest

33+ D.Datatype name tvars ctors : rest ->

34+ (:) (D.Datatype name tvars ctors) <$> go rest

2835

29− TypeAlias name tvars alias : rest ->

30− (:) (TypeAlias name tvars alias) <$> go rest

36+ D.TypeAlias name tvars alias : rest ->

37+ (:) (D.TypeAlias name tvars alias) <$> go rest

3138

32− Fixity assoc prec op : rest ->

33− (:) (Fixity assoc prec op) <$> go rest

39+ D.Fixity assoc prec op : rest ->

40+ (:) (D.Fixity assoc prec op) <$> go rest

3441

3542 -- combine definitions

3643 D.Definition def : defRest ->

3744 case def of

38− Def pat expr ->

45+ Source.Definition pat expr ->

3946 do expr' <- exprCombineAnnotations expr

40− let def' = E.Definition pat expr' Nothing

47+ let def' = Valid.Definition pat expr' Nothing

4148 (:) (D.Definition def') <$> go defRest

4249

43− TypeAnnotation name tipe ->

50+ Source.TypeAnnotation name tipe ->

4451 case defRest of

45− D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->

46− do expr' <- exprCombineAnnotations expr

47− let def' = E.Definition pat expr' (Just tipe)

48− (:) (D.Definition def') <$> go rest

52+ D.Definition (Source.Definition pat@(P.Var name') expr) : rest

53+ | name == name' ->

54+ do expr' <- exprCombineAnnotations expr

55+ let def' = Valid.Definition pat expr' (Just tipe)

56+ (:) (D.Definition def') <$> go rest

4957

5058 _ -> Left (msg name)

5159

5260 -- combine ports

53− Port port : portRest ->

61+ D.Port port : portRest ->

5462 case port of

55− PPDef name _ -> Left (msg name)

56− PPAnnotation name tipe ->

63+ D.PPDef name _ -> Left (msg name)

64+ D.PPAnnotation name tipe ->

5765 case portRest of

58− Port (PPDef name' expr) : rest | name == name' ->

66+ D.Port (D.PPDef name' expr) : rest | name == name' ->

5967 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..]

61122

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)

63126

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

22module Transform.Definition where

33

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

5−import qualified SourceSyntax.Pattern as P

6−import SourceSyntax.Expression

5+import qualified AST.Pattern as P

6+import qualified AST.Expression.Source as Source

7+import qualified AST.Expression.Valid as Valid

78import qualified Transform.Expression as Expr

89

9−combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

1011combineAnnotations = go

1112 where

1213 msg x = "Syntax Error: The type annotation for '" ++ x ++

@@ -16,16 +17,19 @@ combineAnnotations = go

1617

1718 go defs =

1819 case defs of

19− TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->

20− do expr' <- exprCombineAnnotations expr

21− let def = Definition pat expr' (Just tipe)

22− (:) def <$> go rest

20+ Source.TypeAnnotation name tipe : rest ->

21+ case rest of

22+ Source.Definition pat@(P.Var name') expr : rest'

23+ | name == name' ->

24+ do expr' <- exprCombineAnnotations expr

25+ let def = Valid.Definition pat expr' (Just tipe)

26+ (:) def <$> go rest'

2327

24− TypeAnnotation name _ : _ -> Left (msg name)

28+ _ -> Left (msg name)

2529

26− Def pat expr : rest ->

30+ Source.Definition pat expr : rest ->

2731 do expr' <- exprCombineAnnotations expr

28− let def = Definition pat expr' Nothing

32+ let def = Valid.Definition pat expr' Nothing

2933 (:) def <$> go rest

3034

3135 [] -> return []

compiler/Transform/Expression.hs+15−14

@@ -2,31 +2,32 @@

22module Transform.Expression (crawlLet, checkPorts) where

33

44import Control.Applicative ((<$>),(<*>))

5−import SourceSyntax.Annotation ( Annotated(A) )

6−import SourceSyntax.Expression

7−import SourceSyntax.Type (Type)

5+import AST.Annotation ( Annotated(A) )

6+import AST.Expression.General

7+import qualified AST.Expression.Canonical as Canonical

8+import AST.Type (Type, CanonicalType)

89

910crawlLet :: ([def] -> Either a [def'])

10− -> GeneralExpr ann def var

11− -> Either a (GeneralExpr ann def' var)

11+ -> Expr ann def var

12+ -> Either a (Expr ann def' var)

1213crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

1314

14−checkPorts :: (String -> Type -> Either a ())

15− -> (String -> Type -> Either a ())

16− -> Expr

17− -> Either a Expr

15+checkPorts :: (String -> CanonicalType -> Either a ())

16+ -> (String -> CanonicalType -> Either a ())

17+ -> Canonical.Expr

18+ -> Either a Canonical.Expr

1819checkPorts inCheck outCheck expr =

1920 crawl inCheck outCheck (mapM checkDef) expr

2021 where

21− checkDef def@(Definition _ body _) =

22+ checkDef def@(Canonical.Definition _ body _) =

2223 do _ <- checkPorts inCheck outCheck body

2324 return def

2425

25−crawl :: (String -> Type -> Either a ())

26− -> (String -> Type -> Either a ())

26+crawl :: (String -> Type var -> Either a ())

27+ -> (String -> Type var -> Either a ())

2728 -> ([def] -> Either a [def'])

28− -> GeneralExpr ann def var

29− -> Either a (GeneralExpr ann def' var)

29+ -> Expr ann def var

30+ -> Either a (Expr ann def' var)

3031crawl portInCheck portOutCheck defsTransform = go

3132 where

3233 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

77import qualified Data.Map as Map

88import qualified Data.Maybe as Maybe

99import 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

1410

15−ctors :: P.Pattern -> [String]

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+

17+ctors :: P.CanonicalPattern -> [String]

1618ctors pattern =

1719 case pattern of

1820 P.Var _ -> []

1921 P.Alias _ p -> ctors p

20− P.Data ctor ps -> ctor : concatMap ctors ps

2122 P.Record _ -> []

2223 P.Anything -> []

2324 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

2432

2533free :: String -> State (Set.Set String) ()

2634free x = modify (Set.insert x)

2735

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+

2843bound :: Set.Set String -> State (Set.Set String) ()

2944bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

3045

31−sortDefs :: Expr -> Expr

46+sortDefs :: Canonical.Expr -> Canonical.Expr

3247sortDefs expr = evalState (reorder expr) Set.empty

3348

34−reorder :: Expr -> State (Set.Set String) Expr

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

3550reorder (A ann expr) =

3651 A ann <$>

3752 case expr of

3853 -- Be careful adding and restricting freeVars

39− Var (V.Raw x) -> free x >> return expr

54+ Var var -> freeIfLocal var >> return expr

4055

4156 Lambda p e ->

4257 uncurry Lambda <$> bindingReorder (p,e)

4358

4459 Binop op e1 e2 ->

45− do free op

60+ do freeIfLocal op

4661 Binop op <$> reorder e1 <*> reorder e2

4762

4863 Case e cases ->

@@ -102,7 +117,7 @@ reorder (A ann expr) =

102117 let defss = map Graph.flattenSCC sccs

103118

104119 -- remove let-bound variables from the context

105− forM_ defs $ \(Definition pattern _ _) -> do

120+ forM_ defs $ \(Canonical.Definition pattern _ _) -> do

106121 bound (P.boundVars pattern)

107122 mapM free (ctors pattern)

108123

@@ -110,7 +125,8 @@ reorder (A ann expr) =

110125

111126 return let'

112127

113−bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)

128+bindingReorder :: (P.CanonicalPattern, Canonical.Expr)

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

114130bindingReorder (pattern,expr) =

115131 do expr' <- reorder expr

116132 bound (P.boundVars pattern)

@@ -118,8 +134,8 @@ bindingReorder (pattern,expr) =

118134 return (pattern, expr')

119135

120136

121−reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

122−reorderAndGetDependencies (Definition pattern expr mType) =

137+reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String])

138+reorderAndGetDependencies (Canonical.Definition pattern expr mType) =

123139 do globalFrees <- get

124140 -- work in a fresh environment

125141 put Set.empty

@@ -127,28 +143,28 @@ reorderAndGetDependencies (Definition pattern expr mType) =

127143 localFrees <- get

128144 -- merge with global frees

129145 modify (Set.union globalFrees)

130− return (Definition pattern expr' mType, Set.toList localFrees)

146+ return (Canonical.Definition pattern expr' mType, Set.toList localFrees)

131147

132148

133149-- 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])]

135151buildDefDict defs =

136152 do pdefsDeps <- mapM reorderAndGetDependencies defs

137153 return $ realDeps (addKey pdefsDeps)

138154

139155 where

140− addKey :: [(Def, [String])] -> [(Def, Int, [String])]

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

141157 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

142158

143− variableToKey :: (Def, Int, [String]) -> [(String, Int)]

144− variableToKey (Definition pattern _ _, key, _) =

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

160+ variableToKey (Canonical.Definition pattern _ _, key, _) =

145161 [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

146162

147− variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

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

148164 variableToKeyMap pdefsDeps =

149165 Map.fromList (concatMap variableToKey pdefsDeps)

150166

151− realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

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

152168 realDeps pdefsDeps = map convert pdefsDeps

153169 where

154170 varDict = variableToKeyMap pdefsDeps

compiler/Transform/Substitute.hs+14−8

@@ -4,12 +4,13 @@ module Transform.Substitute (subst) where

44import Control.Arrow (second, (***))

55import qualified Data.Set as Set

66

7−import SourceSyntax.Annotation

8−import SourceSyntax.Expression

9−import qualified SourceSyntax.Pattern as Pattern

10−import qualified SourceSyntax.Variable as V

7+import AST.Annotation

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

9+import qualified AST.Expression.Canonical as Canonical

10+import qualified AST.Pattern as Pattern

11+import qualified AST.Variable as V

1112

12−subst :: String -> Expr' -> Expr' -> Expr'

13+subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr'

1314subst old new expr =

1415 let f (A a e) = A a (subst old new e) in

1516 case expr of

@@ -26,11 +27,16 @@ subst old new expr =

2627 | anyShadow -> expr

2728 | otherwise -> Let (map substDef defs) (f body)

2829 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

3031 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

3239

33− Var (V.Raw x) -> if x == old then new else expr

3440 Case e cases -> Case (f e) $ map (second f) cases

3541 Data name es -> Data name (map f es)

3642 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

88import qualified Data.Map as Map

99import qualified Text.PrettyPrint as PP

1010

11−import SourceSyntax.Literal as Lit

12−import SourceSyntax.Annotation as Ann

13−import SourceSyntax.Expression

14−import qualified SourceSyntax.Pattern as P

15−import qualified SourceSyntax.Type as ST

16−import qualified SourceSyntax.Variable as V

11+import AST.Literal as Lit

12+import AST.Annotation as Ann

13+import AST.Expression.General

14+import qualified AST.Expression.Canonical as Canonical

15+import qualified AST.Pattern as P

16+import qualified AST.Type as ST

17+import qualified AST.Variable as V

1718import Type.Type hiding (Descriptor(..))

1819import Type.Fragment

1920import qualified Type.Environment as Env

2021import qualified Type.Constrain.Literal as Literal

2122import qualified Type.Constrain.Pattern as Pattern

2223

23−constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

24+constrain :: Env.Environment -> Canonical.Expr -> Type

25+ -> ErrorT [PP.Doc] IO TypeConstraint

2426constrain env (A region expr) tipe =

2527 let list t = Env.get env Env.types "_List" <| t

2628 and = A region . CAnd

@@ -45,12 +47,14 @@ constrain env (A region expr) tipe =

4547 else record (Map.map (\t -> [glTipe t]) decls) baseRec

4648 attribute = makeRec Lit.attribute attr

4749 uniform = makeRec Lit.uniform unif

48− varying = makeRec Lit.varying (TermN EmptyRecord1)

50+ varying = makeRec Lit.varying (termN EmptyRecord1)

4951 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)

5052

51− Var (V.Raw name)

53+ Var var

5254 | name == saveEnvName -> return (A region CSaveEnv)

5355 | otherwise -> return (name <? tipe)

56+ where

57+ name = V.toString var

5458

5559 Range lo hi ->

5660 existsNumber $ \n -> do

@@ -68,7 +72,7 @@ constrain env (A region expr) tipe =

6872 exists $ \t2 -> do

6973 c1 <- constrain env e1 t1

7074 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) ]

7276

7377 Lambda p e ->

7478 exists $ \t1 ->

@@ -102,8 +106,8 @@ constrain env (A region expr) tipe =

102106 and . (:) ce <$> mapM branch branches

103107

104108 Data name exprs ->

105− do vars <- forM exprs $ \_ -> liftIO (var Flexible)

106− let pairs = zip exprs (map VarN vars)

109+ do vars <- forM exprs $ \_ -> liftIO (variable Flexible)

110+ let pairs = zip exprs (map varN vars)

107111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

108112 return $ ex vars (cs /\ name <? ctipe)

109113 where

@@ -129,28 +133,28 @@ constrain env (A region expr) tipe =

129133

130134 Modify e fields ->

131135 exists $ \t -> do

132− oldVars <- forM fields $ \_ -> liftIO (var Flexible)

133− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))

136+ oldVars <- forM fields $ \_ -> liftIO (variable Flexible)

137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

134138 cOld <- ex oldVars <$> constrain env e (record oldFields t)

135139

136− newVars <- forM fields $ \_ -> liftIO (var Flexible)

137− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))

140+ newVars <- forM fields $ \_ -> liftIO (variable Flexible)

141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

138142 let cNew = tipe === record newFields t

139143

140− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)

144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)

141145

142146 return $ cOld /\ ex newVars (and (cNew : cs))

143147

144148 Record fields ->

145− do vars <- forM fields $ \_ -> liftIO (var Flexible)

146− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)

147− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))

148− recordType = record fields' (TermN EmptyRecord1)

149+ do vars <- forM fields $ \_ -> liftIO (variable Flexible)

150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)

151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

152+ recordType = record fields' (termN EmptyRecord1)

149153 return . ex vars . and $ tipe === recordType : cs

150154

151155 Markdown _ _ es ->

152− do vars <- forM es $ \_ -> liftIO (var Flexible)

153− let tvars = map VarN vars

156+ do vars <- forM es $ \_ -> liftIO (variable Flexible)

157+ let tvars = map varN vars

154158 cs <- zipWithM (constrain env) es tvars

155159 return . ex vars $ and ("Text.markdown" <? tipe : cs)

156160

@@ -169,16 +173,16 @@ constrain env (A region expr) tipe =

169173 PortOut _ _ signal ->

170174 constrain env signal tipe

171175

172−constrainDef env info (Definition pattern expr maybeTipe) =

176+constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

173177 let qs = [] -- should come from the def, but I'm not sure what would live there...

174178 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

175179 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.

177181 -- Currently, qs is always [].

178182 case (pattern, maybeTipe) of

179183 (P.Var name, Just tipe) -> do

180− flexiVars <- forM qs (\_ -> liftIO $ var Flexible)

181− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

184+ flexiVars <- forM qs (\_ -> liftIO $ variable Flexible)

185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

182186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

183187 (vars, typ) <- Env.instantiateType env tipe Map.empty

184188 let scheme = Scheme { rigidQuantifiers = [],

@@ -194,9 +198,9 @@ constrainDef env info (Definition pattern expr maybeTipe) =

194198 , fl rigidVars c /\ c1 )

195199

196200 (P.Var name, Nothing) -> do

197− v <- liftIO $ var Flexible

198− let tipe = VarN v

199− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

201+ v <- liftIO $ variable Flexible

202+ let tipe = varN v

203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

200204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

201205 c <- constrain env' expr tipe

202206 return ( schemes

@@ -206,18 +210,18 @@ constrainDef env info (Definition pattern expr maybeTipe) =

206210 , c /\ c2

207211 , c1 )

208212

209− _ -> error (show pattern)

213+ _ -> error ("problem in constrainDef with " ++ show pattern)

210214

211−expandPattern :: Def -> [Def]

212−expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =

215+expandPattern :: Canonical.Def -> [Canonical.Def]

216+expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) =

213217 case pattern of

214218 P.Var _ -> [def]

215− _ -> Definition (P.Var x) lexpr maybeType : map toDef vars

219+ _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars

216220 where

217221 vars = P.boundVarList pattern

218222 x = "$" ++ concat vars

219− mkVar = A r . rawVar

220− toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

223+ mkVar = A r . localVar

224+ toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

221225

222226try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

223227try region computation = do

compiler/Type/Constrain/Literal.hs+3−3

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

11{-# OPTIONS_GHC -W #-}

22module Type.Constrain.Literal where

33

4−import SourceSyntax.Annotation

5−import SourceSyntax.Literal

4+import AST.Annotation

5+import AST.Literal

66import Type.Type

77import Type.Environment as Env

88

@@ -15,7 +15,7 @@ constrain env region literal tipe =

1515

1616 litType =

1717 case literal of

18− IntNum _ -> VarN `fmap` var (Is Number)

18+ IntNum _ -> varN `fmap` variable (Is Number)

1919 FloatNum _ -> prim "Float"

2020 Chr _ -> prim "Char"

2121 Str _ -> prim "String"

compiler/Type/Constrain/Pattern.hs+18−15

@@ -9,20 +9,21 @@ import Control.Monad.Error

99import qualified Data.Map as Map

1010import qualified Text.PrettyPrint as PP

1111

12−import qualified SourceSyntax.Annotation as A

13−import qualified SourceSyntax.Pattern as P

14−import SourceSyntax.PrettyPrint (pretty)

12+import qualified AST.Annotation as A

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as V

15+import AST.PrettyPrint (pretty)

1516import Type.Type

1617import Type.Fragment

1718import Type.Environment as Env

1819import qualified Type.Constrain.Literal as Literal

1920

2021

21−constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment

22+constrain :: Environment -> P.CanonicalPattern -> Type

23+ -> ErrorT (A.Region -> PP.Doc) IO Fragment

2224constrain env pattern tipe =

2325 let region = A.None (pretty pattern)

2426 t1 === t2 = A.A region (CEqual t1 t2)

25− x <? t = A.A region (CInstance x t)

2627 in

2728 case pattern of

2829 P.Anything -> return emptyFragment

@@ -32,23 +33,25 @@ constrain env pattern tipe =

3233 return $ emptyFragment { typeConstraint = c }

3334

3435 P.Var name -> do

35− v <- liftIO $ var Flexible

36+ v <- liftIO $ variable Flexible

3637 return $ Fragment {

37− typeEnv = Map.singleton name (VarN v),

38+ typeEnv = Map.singleton name (varN v),

3839 vars = [v],

39− typeConstraint = VarN v === tipe

40+ typeConstraint = varN v === tipe

4041 }

4142

4243 P.Alias name p -> do

44+ v <- liftIO $ variable Flexible

4345 fragment <- constrain env p tipe

44− return $ fragment {

45− typeEnv = Map.insert name tipe (typeEnv fragment),

46− typeConstraint = name <? tipe /\ typeConstraint fragment

46+ return $ fragment

47+ { typeEnv = Map.insert name (varN v) (typeEnv fragment)

48+ , vars = v : vars fragment

49+ , typeConstraint = varN v === tipe /\ typeConstraint fragment

4750 }

4851

4952 P.Data name patterns -> do

50− (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

51− let msg = concat [ "Constructor '", name, "' expects ", show kind

53+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)

54+ let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind

5255 , " argument", if kind == 1 then "" else "s"

5356 , " but was given ", show (length patterns), "." ]

5457 err span = PP.vcat [ PP.text $ "Type error " ++ show span

@@ -63,8 +66,8 @@ constrain env pattern tipe =

6366 }

6467

6568 P.Record fields -> do

66− pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

67− let tenv = Map.fromList (map (second VarN) pairs)

69+ pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields

70+ let tenv = Map.fromList (map (second varN) pairs)

6871 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

6972 return $ Fragment {

7073 typeEnv = tenv,

compiler/Type/Environment.hs+84−86

@@ -4,7 +4,6 @@ module Type.Environment where

44import Control.Applicative ((<$>), (<*>))

55import Control.Exception (try, SomeException)

66import Control.Monad

7−import Control.Monad.Trans.Error (ErrorList(..))

87import Control.Monad.Error (ErrorT, throwError, liftIO)

98import qualified Control.Monad.State as State

109import qualified Data.Traversable as Traverse

@@ -12,55 +11,59 @@ import qualified Data.Map as Map

1211import Data.List (isPrefixOf)

1312import qualified Text.PrettyPrint as PP

1413

15−import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT, Alias)

14+import qualified AST.Type as T

15+import qualified AST.Variable as V

16+import AST.Module (CanonicalAdt, AdtInfo)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

2020type VarDict = Map.Map String Variable

2121

22−data Environment = Environment {

23− constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)),

24− aliases :: Map.Map String ([String], Src.Type),

25− types :: TypeDict,

26− value :: TypeDict

27−}

22+data Environment = Environment

23+ { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

24+ , types :: TypeDict

25+ , value :: TypeDict

26+ }

2827

29−initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30−initialEnvironment datatypes aliases = do

28+initialEnvironment :: [CanonicalAdt] -> IO Environment

29+initialEnvironment datatypes = do

3130 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

33− env = Environment {

34− constructor = Map.empty,

35− value = Map.empty,

36− types = types,

37− aliases = aliases' }

38−

31+ let env = Environment

32+ { constructor = Map.empty

33+ , value = Map.empty

34+ , types = types

35+ }

3936 return $ env { constructor = makeConstructors env datatypes }

4037

41−makeTypes :: [ADT] -> IO TypeDict

42−makeTypes datatypes =

43− Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

38+makeTypes :: [CanonicalAdt] -> IO TypeDict

39+makeTypes datatypes =

40+ do adts <- mapM makeImported datatypes

41+ bs <- mapM makeBuiltin builtins

42+ return (Map.fromList (adts ++ bs))

4443 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

46−

47− makeCtor (name, _) = do

48− ctor <- VarN <$> namedVar Constant name

49− return (name, ctor)

44+ makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)

45+ makeImported (var, _) = do

46+ tvar <- namedVar Constant var

47+ return (V.toString var, varN tvar)

5048

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

5253

53− kind n names = map (\name -> (name, n)) names

54−

55− builtins :: [(String,Int)]

54+ builtins :: [(String, Int)]

5655 builtins = concat [ map tuple [0..9]

5756 , kind 1 ["_List"]

5857 , kind 0 ["Int","Float","Char","String","Bool"]

5958 ]

59+ where

60+ tuple n = ("_Tuple" ++ show n, n)

61+ kind n names = map (\name -> (name, n)) names

62+

6063

6164

6265makeConstructors :: Environment

63− -> [ADT]

66+ -> [CanonicalAdt]

6467 -> Map.Map String (IO (Int, [Variable], [Type], Type))

6568makeConstructors env datatypes = Map.fromList builtins

6669 where

@@ -68,8 +71,8 @@ makeConstructors env datatypes = Map.fromList builtins

6871

6972 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

7073 inst numTVars tipe = do

71− vars <- forM [1..numTVars] $ \_ -> var Flexible

72− let (args, result) = tipe (map VarN vars)

74+ vars <- forM [1..numTVars] $ \_ -> variable Flexible

75+ let (args, result) = tipe (map (varN) vars)

7376 return (length args, vars, args, result)

7477

7578 tupleCtor n =

@@ -83,88 +86,83 @@ makeConstructors env datatypes = Map.fromList builtins

8386 ++ concatMap (ctorToType env) datatypes

8487

8588

86−ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

88− zip (map fst ctors) (map inst ctors)

89+ctorToType :: Environment

90+ -> (V.Canonical, AdtInfo V.Canonical)

91+ -> [(String, IO (Int, [Variable], [Type], Type))]

92+ctorToType env (name, (tvars, ctors)) =

93+ zip (map (V.toString . fst) ctors) (map inst ctors)

8994 where

90− inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

95+ inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type)

9196 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

9398 return (length args, Map.elems dict, args, tipe)

9499

95100

96− go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

101+ go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type)

97102 go (_, args) = do

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

100105 return (types, returnType)

101106

102107

103108get :: 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)

105110 where

106− err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."

111+ msg = "Could not find type constructor '" ++ key ++ "' while checking types."

107112

108113

109114freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

110115freshDataScheme env name = get env constructor name

111116

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)

116118instantiateType env sourceType dict =

117− do result <- liftIO $ try (State.runStateT (instantiator env sourceType) (dict, Map.empty))

118− case result :: Either SomeException (Type, (VarDict, TypeDict)) of

119+ do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict)

120+ case result :: Either SomeException (Type, VarDict) of

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

121123

122−instantiator :: Environment -> Src.Type

123− -> State.StateT (VarDict, TypeDict) IO Type

124+instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type

124125instantiator env sourceType = go sourceType

125126 where

126− go :: Src.Type -> State.StateT (VarDict, TypeDict) IO Type

127+ go :: T.CanonicalType -> State.StateT VarDict IO Type

127128 go sourceType =

128129 case sourceType of

129− Src.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

130−

131− Src.Var x -> do

132− (dict, aliases) <- State.get

133− case (Map.lookup x dict, Map.lookup x aliases) of

134− (_, Just t) -> return t

135− (Just v, _) -> return (VarN v)

136− _ ->

137− do var <- State.liftIO $ namedVar flex x

138− State.put (Map.insert x var dict, aliases)

139− return (VarN var)

130+ T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2

131+

132+ T.Var x -> do

133+ dict <- State.get

134+ case Map.lookup x dict of

135+ Just v -> return (varN v)

136+ Nothing ->

137+ do v <- State.liftIO $ namedVar flex (V.local x)

138+ State.put (Map.insert x v dict)

139+ return (varN v)

140140 where

141141 flex | "number" `isPrefixOf` x = Is Number

142142 | "comparable" `isPrefixOf` x = Is Comparable

143143 | "appendable" `isPrefixOf` x = Is Appendable

144144 | otherwise = Flexible

145145

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

147160 ts' <- mapM go ts

148− case (Map.lookup name (types env), Map.lookup name (aliases env)) of

149− (Just t, _) -> return $ foldl (<|) t ts'

150− (_, Just (tvars, t)) ->

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

166− fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

161+ return $ foldl (<|) t' ts'

162+

163+ T.Record fields ext -> do

164+ fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

167165 ext' <- case ext of

168− Nothing -> return $ TermN EmptyRecord1

169− Just x -> go (Src.Var x)

170− return $ TermN (Record1 fields' ext')

166+ Nothing -> return $ termN EmptyRecord1

167+ Just x -> go x

168+ return $ termN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+51−42

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

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

22

33{-| This module contains checks to be run *after* type inference has completed

44successfully. 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

77module Type.ExtraChecks (mainType, occurs, portTypes) where

88

99import Control.Applicative ((<$>),(<*>))

10+import Control.Monad.Error

1011import Control.Monad.State

1112import qualified Data.Map as Map

1213import qualified Data.Traversable as Traverse

1314import qualified Data.UnionFind.IO as UF

1415import Text.PrettyPrint as P

1516

16−import qualified SourceSyntax.Annotation as A

17−import qualified SourceSyntax.Expression as E

18−import qualified SourceSyntax.Helpers as Help

19−import qualified SourceSyntax.PrettyPrint as SPP

20−import qualified SourceSyntax.Type as ST

17+import qualified AST.Annotation as A

18+import qualified AST.Expression.Canonical as Canonical

19+import qualified AST.PrettyPrint as PP

20+import qualified AST.Type as ST

21+import qualified AST.Variable as V

2122import qualified Transform.Expression as Expr

2223import qualified Type.Type as TT

2324import qualified Type.State as TS

24−import qualified Type.Alias as Alias

2525

26+throw :: [Doc] -> Either [Doc] a

2627throw err = Left [ P.vcat err ]

2728

28−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))

29−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

29+mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

30+mainType environment =

31+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment

32+ mainCheck environment'

3033 where

31− mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)

32− mainCheck rules env =

34+ mainCheck :: (Monad m) => Map.Map String ST.CanonicalType

35+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)

36+ mainCheck env =

3337 case Map.lookup "main" env of

34− Nothing -> Right env

35− Just mainType

36− | tipe `elem` acceptable -> Right env

37− | otherwise -> throw err

38+ Nothing -> return env

39+ Just typeOfMain

40+ | tipe `elem` acceptable -> return env

41+ | otherwise -> throwError err

3842 where

3943 acceptable = [ "Graphics.Element.Element"

4044 , "Signal.Signal Graphics.Element.Element" ]

4145

42− tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

46+ tipe = PP.renderPretty typeOfMain

4347 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

4448 , P.text "Instead 'main' has type:\n"

45− , P.nest 4 . SPP.pretty $ Alias.realias rules mainType

49+ , P.nest 4 (PP.pretty typeOfMain)

4650 , P.text " " ]

4751

4852data Direction = In | Out

4953

50−portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()

51−portTypes rules expr =

52− const () <$> Expr.checkPorts (check In) (check Out) expr

54+portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

55+portTypes expr =

56+ case Expr.checkPorts (check In) (check Out) expr of

57+ Left err -> throwError err

58+ Right _ -> return ()

5359 where

5460 check = isValid True False False

5561 isValid isTopLevel seenFunc seenSignal direction name tipe =

5662 case tipe of

57− ST.Data ctor ts

58− | validConstructor -> mapM_ valid ts

59− | ctor == "Signal.Signal" -> handleSignal ts

60− | otherwise -> err' True "an unsupported type"

61− where

62− primitives =

63− ["Int","Float","String","Bool","Maybe.Maybe","_List","Array.Array","Json.Value"]

64− validConstructor =

65− ctor `elem` primitives || Help.isTuple ctor

63+ ST.Aliased _ t -> valid t

64+

65+ ST.Type v

66+ | V.isJson v -> return ()

67+ | V.isPrimitive v -> return ()

68+ | otherwise -> err "an unsupported type"

69+

70+ ST.App t [] -> valid t

71+

72+ ST.App (ST.Type v) [t]

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"

6682

6783 ST.Var _ -> err "free type variables"

6884

@@ -84,30 +100,24 @@ portTypes rules expr =

84100 isValid' = isValid False

85101 valid = isValid' seenFunc seenSignal direction name

86102

87− handleSignal ts

103+ handleSignal t

88104 | seenFunc = err "functions that involve signals"

89105 | seenSignal = err "signals-of-signals"

90− | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

106+ | isTopLevel = isValid' seenFunc True direction name t

91107 | otherwise = err "a signal within a data stucture"

92108

93109 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

94110 txt = P.text . concat

95111

96− err = err' False

97− err' couldBeAlias kind =

112+ err kind =

98113 throw $

99114 [ txt [ "Type Error: the value ", dir "coming in" "sent out"

100115 , " through port '", name, "' is invalid." ]

101116 , 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"

103118 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]

104119 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]

105120 , 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)." ]

111121 ]

112122

113123occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

@@ -119,17 +129,16 @@ occurs (name, variable) =

119129 desc <- liftIO $ UF.descriptor var

120130 case TT.structure desc of

121131 Nothing ->

122− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

132+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }

123133 Just _ ->

124134 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

125135 var' <- liftIO $ UF.fresh desc

126136 TS.addError (A.None (P.text name)) (Just msg) var var'

127137 where

128138 msg = "Infinite types are not allowed"

129− fallback _ = return $ P.text msg

130139

131140 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]

132− infiniteVars seen var =

141+ infiniteVars seen var =

133142 let go = infiniteVars (var:seen) in

134143 if var `elem` seen

135144 then return [var]

compiler/Type/Fragment.hs+2−2

@@ -4,8 +4,8 @@ import qualified Data.List as List

44import qualified Data.Map as Map

55

66import Type.Type

7−import SourceSyntax.Pattern

8−import SourceSyntax.Annotation (noneNoDocs)

7+import AST.Pattern

8+import AST.Annotation (noneNoDocs)

99

1010data Fragment = Fragment

1111 { typeEnv :: Map.Map String Type

compiler/Type/Inference.hs+74−38

@@ -8,50 +8,86 @@ import qualified Type.Environment as Env

88import qualified Type.Constrain.Expression as TcExpr

99import qualified Type.Solve as Solve

1010

11−import SourceSyntax.Module as Module

12−import SourceSyntax.Annotation (noneNoDocs)

13−import SourceSyntax.Type (Type)

11+import qualified AST.Annotation as A

12+import AST.Module as Module

13+import AST.Type (CanonicalType)

14+import qualified AST.Variable as Var

1415import Text.PrettyPrint

1516import qualified Type.State as TS

1617import qualified Type.ExtraChecks as Check

18+import Control.Arrow (first, second)

1719import Control.Monad.State (execStateT, forM)

18−import Control.Monad.Error (runErrorT, liftIO)

19−import qualified Type.Alias as Alias

20+import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError)

2021

2122import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

2223 -- the IO monad. I don't think that'd be worthwhile.

2324

2425

25−infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

26−infer interfaces modul = unsafePerformIO $ do

27− env <- Env.initialEnvironment

28− (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

29− (aliases modul ++ concatMap iAliases (Map.elems interfaces))

30− ctors <- forM (Map.keys (Env.constructor env)) $ \name ->

31− do (_, vars, args, result) <- Env.freshDataScheme env name

32− return (name, (vars, foldr (T.==>) result args))

33−

34− attemptConstraint <- runErrorT $ do

35− importedVars <-

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

40− vars = concatMap (fst . snd) allTypes

41− header = Map.map snd (Map.fromList allTypes)

42− environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]

43−

44− fvar <- liftIO $ T.var T.Flexible

45− c <- TcExpr.constrain env (program modul) (T.VarN fvar)

46− return (header, environ c)

47−

48− case attemptConstraint of

49− Left err -> return $ Left err

50− Right (header, constraint) -> do

51− state <- execStateT (Solve.solve constraint) TS.initialState

52− let rules = Alias.rules interfaces (aliases modul) (imports modul)

53− case TS.sErrors state of

54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

55− [] -> case Check.portTypes rules (program modul) of

56− Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

57− Left err -> return (Left err)

26+infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)

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

47+ env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)

48+

49+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do

50+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name

51+ return (name, (vars, foldr (T.==>) result args))

52+

53+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)

54+

55+ let allTypes = concat (ctors : importedVars)

56+ vars = concatMap (fst . snd) allTypes

57+ header = Map.map snd (Map.fromList allTypes)

58+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]

59+

60+ fvar <- liftIO $ T.variable T.Flexible

61+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)

62+ return (header, environ c)

63+

64+

65+canonicalizeValues :: Env.Environment -> (String, Interface)

66+ -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]

67+canonicalizeValues env (moduleName, iface) =

68+ forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do

69+ tipe' <- Env.instantiateType env tipe Map.empty

70+ return (moduleName ++ "." ++ name, tipe')

71+

72+canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]

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

22module Type.PrettyPrint where

33

44import Text.PrettyPrint

5−import qualified SourceSyntax.PrettyPrint as Src

5+import qualified AST.PrettyPrint as Src

66

77data ParensWhen = Fn | App | Never

88

99class PrettyType a where

1010 pretty :: ParensWhen -> a -> Doc

1111

12+commaSep :: [Doc] -> Doc

1213commaSep docs = sep (punctuate comma docs)

1314

15+parensIf :: Bool -> Doc -> Doc

1416parensIf 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

1111import Type.Unify

1212import qualified Type.ExtraChecks as Check

1313import qualified Type.State as TS

14−import qualified SourceSyntax.Annotation as A

14+import qualified AST.Annotation as A

1515

1616

1717-- | Every variable has rank less than or equal to the maxRank of the pool.

@@ -21,9 +21,9 @@ generalize youngPool = do

2121 youngMark <- TS.uniqueMark

2222 let youngRank = TS.maxRank youngPool

2323 insert dict var = do

24− desc <- liftIO $ UF.descriptor var

24+ descriptor <- liftIO $ UF.descriptor var

2525 liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

26− return $ Map.insertWith (++) (rank desc) [var] dict

26+ return $ Map.insertWith (++) (rank descriptor) [var] dict

2727

2828 -- Sort the youngPool variables by rank.

2929 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -32,7 +32,8 @@ generalize youngPool = do

3232 -- start at low ranks so that we only have to pass

3333 -- over the information once.

3434 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

3637

3738 -- For variables that have rank lowerer than youngRank, register them in

3839 -- the old pool if they are not redundant.

@@ -64,35 +65,38 @@ generalize youngPool = do

6465-- adjust the ranks of variables such that ranks never increase as you

6566-- move deeper into a variable.

6667adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

67−adjustRank youngMark visitedMark groupRank variable =

68− let adjust = adjustRank youngMark visitedMark groupRank in

69− do desc <- liftIO $ UF.descriptor variable

68+adjustRank youngMark visitedMark groupRank var =

69+ do descriptor <- liftIO $ UF.descriptor var

7070 case () of

71− () | mark desc == youngMark ->

71+ () | mark descriptor == youngMark ->

7272 do -- Set the variable as marked first because it may be cyclic.

73− liftIO $ UF.modifyDescriptor variable $ \desc -> desc { mark = visitedMark }

74− rank' <- case structure desc of

75− Nothing -> return groupRank

76− Just term ->

77− case term of

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

73+ liftIO $ UF.modifyDescriptor var $ \desc ->

74+ desc { mark = visitedMark }

75+ rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

76+ liftIO $ UF.modifyDescriptor var $ \desc ->

77+ desc { rank = rank' }

8778 return rank'

8879

89− | mark desc /= visitedMark ->

90− do let rank' = min groupRank (rank desc)

91− liftIO $ UF.setDescriptor variable (desc { mark = visitedMark, rank = rank' })

80+ | mark descriptor /= visitedMark ->

81+ do let rank' = min groupRank (rank descriptor)

82+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

9283 return rank'

9384

94− | otherwise -> return (rank desc)

85+ | otherwise -> return (rank descriptor)

86+

87+ where

88+ adjust = adjustRank youngMark visitedMark groupRank

9589

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

96100

97101

98102solve :: TypeConstraint -> StateT TS.SolverState IO ()

@@ -129,7 +133,7 @@ solve (A.A region constraint) =

129133 case Map.lookup name env of

130134 Just tipe -> TS.makeInstance tipe

131135 Nothing

132− | List.isPrefixOf "Native." name -> liftIO (var Flexible)

136+ | List.isPrefixOf "Native." name -> liftIO (variable Flexible)

133137 | otherwise ->

134138 error ("Could not find '" ++ name ++ "' when solving type constraints.")

135139

compiler/Type/State.hs+40−35

@@ -1,16 +1,15 @@

11{-# OPTIONS_GHC -W #-}

22module Type.State where

33

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

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

55import Control.Monad.State

66import qualified Data.Map as Map

77import qualified Data.Traversable as Traversable

88import qualified Data.UnionFind.IO as UF

99

10−import qualified SourceSyntax.Annotation as A

11−import SourceSyntax.PrettyPrint

10+import qualified AST.Annotation as A

11+import AST.PrettyPrint

1212import Text.PrettyPrint as P

13−import qualified Type.Alias as Alias

1413import Type.Type

1514

1615-- Pool

@@ -18,10 +17,10 @@ import Type.Type

1817-- The rank of each variable is less than or equal to the pool's "maxRank"

1918-- The young pool exists to make it possible to identify these vars in constant time.

2019

21−data Pool = Pool {

22− maxRank :: Int,

23− inhabitants :: [Variable]

24−} deriving Show

20+data Pool = Pool

21+ { maxRank :: Int

22+ , inhabitants :: [Variable]

23+ } deriving Show

2524

2625emptyPool = Pool { maxRank = outermostRank, inhabitants = [] }

2726

@@ -33,7 +32,7 @@ data SolverState = SS {

3332 sSavedEnv :: Env,

3433 sPool :: Pool,

3534 sMark :: Int,

36− sErrors :: [Alias.Rules -> IO P.Doc]

35+ sErrors :: [P.Doc]

3736}

3837

3938initialState = SS {

@@ -47,13 +46,15 @@ initialState = SS {

4746modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

4847modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

4948

49+addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor

50+ -> StateT SolverState IO ()

5051addError 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 }

5254 where

53− makeError rules = do

54− let prettiest = pretty . Alias.realias rules

55− t1' <- prettiest <$> toSrcType t1

56− t2' <- prettiest <$> toSrcType t2

55+ makeError = do

56+ t1' <- pretty <$> toSrcType t1

57+ t2' <- pretty <$> toSrcType t2

5758 return . P.vcat $

5859 [ P.text "Type error" <+> pretty region <> P.colon

5960 , maybe P.empty P.text hint

@@ -103,17 +104,20 @@ introduce variable = do

103104flatten :: Type -> StateT SolverState IO Variable

104105flatten term =

105106 case term of

106− VarN v -> return v

107− TermN t -> do

107+ VarN maybeAlias v -> do

108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

109+ return v

110+ TermN maybeAlias t -> do

108111 flatStructure <- traverseTerm flatten t

109112 pool <- getPool

110− var <- liftIO . UF.fresh $ Descriptor {

111− structure = Just flatStructure,

112− rank = maxRank pool,

113− flex = Flexible,

114− name = Nothing,

115− copy = Nothing,

116− mark = noMark

113+ var <- liftIO . UF.fresh $ Descriptor

114+ { structure = Just flatStructure

115+ , rank = maxRank pool

116+ , flex = Flexible

117+ , name = Nothing

118+ , copy = Nothing

119+ , mark = noMark

120+ , alias = maybeAlias

117121 }

118122 register var

119123

@@ -139,18 +143,19 @@ makeCopy alreadyCopied variable = do

139143

140144 | otherwise -> do

141145 pool <- getPool

142− newVar <- liftIO $ UF.fresh $ Descriptor {

143− structure = Nothing,

144− rank = maxRank pool,

145− mark = noMark,

146− flex = case flex desc of

147− Is s -> Is s

148− _ -> Flexible,

149− copy = Nothing,

150− name = case flex desc of

151− Rigid -> Nothing

152− _ -> name desc

153− }

146+ newVar <- liftIO $ UF.fresh $ Descriptor

147+ { structure = Nothing

148+ , rank = maxRank pool

149+ , mark = noMark

150+ , flex = case flex desc of

151+ Is s -> Is s

152+ _ -> Flexible

153+ , copy = Nothing

154+ , name = case flex desc of

155+ Rigid -> Nothing

156+ _ -> name desc

157+ , alias = Nothing

158+ }

154159 register newVar

155160

156161 -- 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 #-}

12module Type.Type where

23

34import qualified Data.Char as Char

@@ -8,12 +9,13 @@ import Type.PrettyPrint

89import Text.PrettyPrint as P

910import System.IO.Unsafe

1011import Control.Applicative ((<$>),(<*>))

11−import Control.Monad.State

12−import Control.Monad.Error

12+import Control.Monad.State (StateT, get, put, execStateT, runStateT)

13+import Control.Monad.Error (ErrorT, Error, liftIO)

1314import Data.Traversable (traverse)

14−import SourceSyntax.Annotation

15−import SourceSyntax.Helpers (isTuple)

16−import qualified SourceSyntax.Type as Src

15+import AST.Annotation

16+import qualified AST.PrettyPrint as PP

17+import qualified AST.Type as T

18+import qualified AST.Variable as Var

1719

1820data Term1 a

1921 = App1 a a

@@ -24,18 +26,24 @@ data Term1 a

2426 deriving Show

2527

2628data TermN a

27− = VarN a

28− | TermN (Term1 (TermN a))

29+ = VarN (Maybe Var.Canonical) a

30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))

2931 deriving Show

3032

33+varN :: a -> TermN a

34+varN = VarN Nothing

35+

36+termN :: (Term1 (TermN a)) -> TermN a

37+termN = TermN Nothing

38+

3139record :: 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)

3341

3442type Type = TermN Variable

3543type Variable = UF.Point Descriptor

3644

3745type SchemeName = String

38−type TypeName = String

46+type TypeName = Var.Canonical

3947

4048type Constraint a b = Located (BasicConstraint a b)

4149data BasicConstraint a b

@@ -57,6 +65,7 @@ data Scheme a b = Scheme {

5765type TypeConstraint = Constraint Type Variable

5866type TypeScheme = Scheme Type Variable

5967

68+monoscheme :: Map.Map String a -> Scheme a b

6069monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6170

6271infixl 8 /\

@@ -70,23 +79,31 @@ a@(A _ c1) /\ b@(A _ c2) =

7079

7180infixr 9 ==>

7281(==>) :: Type -> Type -> Type

73−a ==> b = TermN (Fun1 a b)

74−

75−f <| a = TermN (App1 f a)

76−

77−data Descriptor = Descriptor {

78− structure :: Maybe (Term1 Variable),

79− rank :: Int,

80− flex :: Flex,

81− name :: Maybe TypeName,

82− copy :: Maybe Variable,

83− mark :: Int

84−} deriving Show

85−

82+a ==> b = termN (Fun1 a b)

83+

84+(<|) :: TermN a -> TermN a -> TermN a

85+f <| a = termN (App1 f a)

86+

87+data Descriptor = Descriptor

88+ { structure :: Maybe (Term1 Variable)

89+ , rank :: Int

90+ , flex :: Flex

91+ , name :: Maybe TypeName

92+ , copy :: Maybe Variable

93+ , mark :: Int

94+ , alias :: Maybe Var.Canonical

95+ } deriving Show

96+

97+noRank :: Int

8698noRank = -1

87−outermostRank = 0 :: Int

8899

100+outermostRank :: Int

101+outermostRank = 0

102+

103+noMark :: Int

89104noMark = 0

105+

106+initialMark :: Int

90107initialMark = 1

91108

92109data Flex = Rigid | Flexible | Constant | Is SuperType

@@ -95,34 +112,26 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95112data SuperType = Number | Comparable | Appendable

96113 deriving (Show, Eq)

97114

98−namedVar :: Flex -> String -> IO Variable

99−namedVar flex name = UF.fresh $ Descriptor {

100− structure = Nothing,

101− rank = noRank,

102− flex = flex,

103− name = Just name,

104− copy = Nothing,

105− mark = noMark

115+namedVar :: Flex -> Var.Canonical -> IO Variable

116+namedVar flex name = UF.fresh $ Descriptor

117+ { structure = Nothing

118+ , rank = noRank

119+ , flex = flex

120+ , name = Just name

121+ , copy = Nothing

122+ , mark = noMark

123+ , alias = Nothing

106124 }

107125

108−var :: Flex -> IO Variable

109−var flex = UF.fresh $ Descriptor {

110− structure = Nothing,

111− rank = noRank,

112− flex = flex,

113− name = Nothing,

114− copy = Nothing,

115− mark = noMark

116− }

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+variable :: Flex -> IO Variable

127+variable flex = UF.fresh $ Descriptor

128+ { structure = Nothing

129+ , rank = noRank

130+ , flex = flex

131+ , name = Nothing

132+ , copy = Nothing

133+ , mark = noMark

134+ , alias = Nothing

126135 }

127136

128137

@@ -138,13 +147,13 @@ fl rqs constraint@(A ann _) =

138147

139148exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

140149exists f = do

141− v <- liftIO $ var Flexible

142− ex [v] <$> f (VarN v)

150+ v <- liftIO $ variable Flexible

151+ ex [v] <$> f (varN v)

143152

144153existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint

145154existsNumber f = do

146− v <- liftIO $ var (Is Number)

147− ex [v] <$> f (VarN v)

155+ v <- liftIO $ variable (Is Number)

156+ ex [v] <$> f (varN v)

148157

149158

150159instance Show a => Show (UF.Point a) where

@@ -187,23 +196,32 @@ instance PrettyType a => PrettyType (Term1 a) where

187196 prettyExt = prty ext

188197 extend | P.render prettyExt == "{}" = P.empty

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

191200 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

192201

193202

194203instance PrettyType a => PrettyType (TermN a) where

195204 pretty when term =

196205 case term of

197− VarN x -> pretty when x

198− TermN t1 -> pretty when t1

199−

206+ VarN alias x -> either alias (pretty when x)

207+ TermN alias t1 -> either alias (pretty when t1)

208+ where

209+ either maybeAlias doc =

210+ case maybeAlias of

211+ Just alias -> PP.pretty alias

212+ Nothing -> doc

200213

201214instance PrettyType Descriptor where

202− pretty when desc =

203− case (structure desc, name desc) of

204− (Just term, _) -> pretty when term

205− (_, Just name) -> if not (isTuple name) then P.text (reprime name) else

206− P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

215+ pretty when desc = do

216+ case (alias desc, structure desc, name desc) of

217+ (Just name, _, _) -> PP.pretty name

218+ (_, Just term, _) -> pretty when term

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+

207225 _ -> P.text "?"

208226

209227

@@ -269,7 +287,7 @@ addNames value = do

269287 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)

270288 let vars = map head . List.group $ List.sort rawVars

271289 suffix s = map (++s) (map (:[]) ['a'..'z'])

272− allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]

290+ allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]

273291 okayVars = filter (`notElem` vars) allVars

274292 runStateT (crawl rename value) (okayVars, 0, 0, 0)

275293 return value

@@ -277,23 +295,20 @@ addNames value = do

277295 getNames desc state@(vars, a, b, c) =

278296 let name' = name desc in

279297 case name' of

280− Just var -> (name', (var:vars, a, b, c))

281− Nothing -> (name', state)

298+ Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c))

299+ _ -> (name', state)

282300

283301 rename desc state@(vars, a, b, c) =

284302 case name desc of

285303 Just var -> (Just var, state)

286304 Nothing ->

287305 case flex desc of

288− Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

289− Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

290− Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

291− other -> (Just $ head vars, (tail vars, a, b, c))

292− where mark = case other of

293− Flexible -> ""

294− Rigid -> "!"

295− Constant -> "#"

296−

306+ Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c))

307+ Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

308+ Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

309+ _ -> (local $ head vars, (tail vars, a, b, c))

310+ where

311+ local v = Just (Var.local v)

297312

298313type CrawlState = ([String], Int, Int, Int)

299314

@@ -329,8 +344,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

329344instance Crawl t => Crawl (TermN t) where

330345 crawl nextState tipe =

331346 case tipe of

332− VarN x -> VarN <$> crawl nextState x

333− TermN term -> TermN <$> crawl nextState term

347+ VarN a x -> VarN a <$> crawl nextState x

348+ TermN a term -> TermN a <$> crawl nextState term

334349

335350instance Crawl t => Crawl (Term1 t) where

336351 crawl nextState term =

@@ -359,50 +374,68 @@ instance Crawl Descriptor where

359374 return $ desc { name = name', structure = structure' }

360375

361376

362−toSrcType :: Variable -> IO Src.Type

363−toSrcType variable = do

364− desc <- UF.descriptor =<< addNames variable

365− case structure desc of

366− Just term ->

377+toSrcType :: Variable -> IO T.CanonicalType

378+toSrcType var =

379+ do desc <- UF.descriptor =<< addNames var

380+ srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

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 =

367395 case term of

368396 App1 a b -> do

369− Src.Data name ts <- toSrcType a

397+ a' <- toSrcType a

370398 b' <- toSrcType b

371− return (Src.Data name (ts ++ [b']))

372− Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

399+ case a' of

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+

373405 Var1 a -> toSrcType a

374− EmptyRecord1 -> return $ Src.Record [] Nothing

406+

407+ EmptyRecord1 -> return $ T.Record [] Nothing

408+

375409 Record1 tfields extension -> do

376410 fields' <- traverse (mapM toSrcType) tfields

377411 let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

378− ext' <- toSrcType extension

412+ ext' <- dealias <$> toSrcType extension

379413 return $ case ext' of

380− Src.Record fs ext -> Src.Record (fs ++ fields) ext

381− Src.Var x -> Src.Record fields (Just x)

414+ T.Record fs ext -> T.Record (fs ++ fields) ext

415+ T.Var _ -> T.Record fields (Just ext')

382416 _ -> error "Used toSrcType on a type that is not well-formed"

383− Nothing ->

384− case name desc of

385− Just x@(c:_) | Char.isLower c -> return (Src.Var x)

386− | otherwise -> return (Src.Data x [])

387− _ -> error $ concat

388− [ "Problem converting the following type "

389− , "from a type-checker type to a source-syntax type:"

390− , P.render (pretty Never variable) ]

417+

418+ dealias :: T.CanonicalType -> T.CanonicalType

419+ dealias t =

420+ case t of

421+ T.Aliased _ t' -> t'

422+ _ -> t

423+

391424

392425data AppStructure = List Variable | Tuple [Variable] | Other

393426

394427collectApps :: Variable -> IO AppStructure

395−collectApps variable = go [] variable

428+collectApps var = go [] var

396429 where

397− go vars variable = do

398− desc <- UF.descriptor variable

430+ go vars var = do

431+ desc <- UF.descriptor var

399432 case (structure desc, vars) of

400433 (Nothing, [v]) -> case name desc of

401− Just "_List" -> return (List v)

402− _ -> return Other

434+ Just n | Var.isList n -> return (List v)

435+ _ -> return Other

403436 (Nothing, vs) -> case name desc of

404− Just ctor | isTuple ctor -> return (Tuple vs)

405− _ -> return Other

437+ Just n | Var.isTuple n -> return (Tuple vs)

438+ _ -> return Other

406439 (Just term, _) -> case term of

407440 App1 a b -> go (vars ++ [b]) a

408441 _ -> return Other

compiler/Type/Unify.hs+81−52

@@ -1,11 +1,14 @@

11{-# OPTIONS_GHC -W #-}

22module Type.Unify (unify) where

33

4+import Control.Applicative ((<|>))

45import Control.Monad.State

6+import qualified Data.List as List

57import qualified Data.Map as Map

68import qualified Data.Maybe as Maybe

79import 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

912import qualified Type.State as TS

1013import Type.Type

1114import Type.PrettyPrint

@@ -23,64 +26,55 @@ actuallyUnify region variable1 variable2 = do

2326 desc2 <- liftIO $ UF.descriptor variable2

2427 let unify' = unify region

2528

26− name' :: Maybe String

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)

29+ (name', flex', rank', alias') = combinedDescriptors desc1 desc2

5130

5231 merge1 :: StateT TS.SolverState IO ()

5332 merge1 = liftIO $ do

5433 if rank desc1 < rank desc2 then UF.union variable2 variable1

5534 else UF.union variable1 variable2

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

5841

5942 merge2 :: StateT TS.SolverState IO ()

6043 merge2 = liftIO $ do

6144 if rank desc1 < rank desc2 then UF.union variable2 variable1

6245 else UF.union variable1 variable2

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

6552

6653 merge = if rank desc1 < rank desc2 then merge1 else merge2

6754

6855 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable

6956 fresh structure = do

70− var <- liftIO . UF.fresh $ Descriptor {

71− structure = structure, rank = rank', flex = flex',

72− name = name', copy = Nothing, mark = noMark

73− }

74− TS.register var

75−

76− flexAndUnify var = do

77− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }

57+ v <- liftIO . UF.fresh $ Descriptor

58+ { structure = structure

59+ , rank = rank'

60+ , flex = flex'

61+ , name = name'

62+ , copy = Nothing

63+ , mark = noMark

64+ , alias = alias'

65+ }

66+ TS.register v

67+

68+ flexAndUnify v = do

69+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

7870 unify' variable1 variable2

7971

80− unifyNumber svar name

81− | name `elem` ["Int","Float","number"] = flexAndUnify svar

82− | otherwise = TS.addError region (Just hint) variable1 variable2

83− where hint = "A number must be an Int or Float."

72+ unifyNumber svar (Var.Canonical home name) =

73+ case home of

74+ Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

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

8478

8579 comparableError maybe =

8680 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

@@ -90,22 +84,24 @@ actuallyUnify region variable1 variable2 = do

9084 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

9185 where msg = "An appendable must be of type String, List, or Text."

9286

93− unifyComparable var name

94− | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

95− | otherwise = comparableError Nothing

87+ unifyComparable v (Var.Canonical home name) =

88+ case home of

89+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v

90+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v

91+ _ -> comparableError Nothing

9692

9793 unifyComparableStructure varSuper varFlex =

9894 do struct <- liftIO $ collectApps varFlex

9995 case struct of

10096 Other -> comparableError Nothing

10197 List v -> do flexAndUnify varSuper

102− unify' v =<< liftIO (var $ Is Comparable)

98+ unify' v =<< liftIO (variable $ Is Comparable)

10399 Tuple vs

104100 | length vs > 6 ->

105101 comparableError $ Just "Cannot compare a tuple with more than 6 elements."

106102 | otherwise ->

107103 do flexAndUnify varSuper

108− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

104+ cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

109105 zipWithM_ unify' vs cmpVars

110106

111107 unifyAppendable varSuper varFlex =

@@ -114,10 +110,10 @@ actuallyUnify region variable1 variable2 = do

114110 List _ -> flexAndUnify varSuper

115111 _ -> appendableError Nothing

116112

117− rigidError variable = TS.addError region (Just hint) variable1 variable2

113+ rigidError var = TS.addError region (Just hint) variable1 variable2

118114 where

119− var = "'" ++ render (pretty Never variable) ++ "'"

120− hint = "Cannot unify rigid type variable " ++ var ++

115+ var' = "'" ++ render (pretty Never var) ++ "'"

116+ hint = "Cannot unify rigid type variable " ++ var' ++

121117 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\

122118 \variables are not shared between a top-level and let-bound type annotations."

123119

@@ -136,10 +132,10 @@ actuallyUnify region variable1 variable2 = do

136132 (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

137133 (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

138134

139− (Is Appendable, _, _, Just ctor)

140− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable1

141− (_, Is Appendable, Just ctor, _)

142− | ctor `elem` ["Text.Text","String"] -> flexAndUnify variable2

135+ (Is Appendable, _, _, Just name)

136+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1

137+ (_, Is Appendable, Just name, _)

138+ | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2

143139 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

144140 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

145141

@@ -202,3 +198,36 @@ actuallyUnify region variable1 variable2 = do

202198

203199 _ -> TS.addError region Nothing variable1 variable2

204200

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.

4646@docs fst, snd

4747

4848# Higher-Order Helpers

49−@docs id, (<|), (|>), (.), always, flip, curry, uncurry

49+@docs id, always, (<|), (|>), (.), flip, curry, uncurry

5050

5151-}

5252

@@ -58,25 +58,25 @@ radians t = t

5858

5959{-| Convert degrees to standard Elm angles (radians). -}

6060degrees : Float -> Float

61−degrees d = d * Native.Basics.pi / 180

61+degrees = Native.Basics.degrees

6262

6363{-| Convert turns to standard Elm angles (radians).

6464One turn is equal to 360°.

6565-}

6666turns : Float -> Float

67−turns r = 2 * Native.Basics.pi * r

67+turns = Native.Basics.turns

6868

6969{-| Start with polar coordinates (r,θ)

7070and get out cartesian coordinates (x,y).

7171-}

7272fromPolar : (Float,Float) -> (Float,Float)

73−fromPolar (r,t) = (r * Native.Basics.cos t, r * Native.Basics.sin t)

73+fromPolar = Native.Basics.fromPolar

7474

7575{-| Start with cartesian coordinates (x,y)

7676and get out polar coordinates (r,θ).

7777-}

7878toPolar : (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

8080

8181(+) : number -> number -> number

8282(+) = Native.Basics.add

@@ -150,7 +150,7 @@ atan2 : Float -> Float -> Float

150150atan2 = Native.Basics.atan2

151151

152152{-| Take the square root of a number. -}

153−sqrt : number -> number

153+sqrt : Float -> Float

154154sqrt = Native.Basics.sqrt

155155

156156{-| Take the absolute value of a number. -}

@@ -158,7 +158,7 @@ abs : number -> number

158158abs = Native.Basics.abs

159159

160160{-| Calculate the logarithm of a number with a given base: `logBase 10 100 == 2` -}

161−logBase : number -> number -> number

161+logBase : Float -> Float -> Float

162162logBase = Native.Basics.logBase

163163

164164{-| Clamps a number within a given range. With the expression

@@ -301,7 +301,19 @@ isInfinite = Native.Basics.isInfinite

301301

302302-- Function Helpers

303303

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

305317(.) : (b -> c) -> (a -> b) -> (a -> c)

306318(.) f g x = f (g x)

307319

libraries/Color.elm+3−3

@@ -60,7 +60,7 @@ with an alpha component for transparency.

6060-}

6161hsla : Float -> Float -> Float -> Float -> Color

6262hsla 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

6464

6565{-| Create [HSL colors](http://en.wikipedia.org/wiki/HSL_and_HSV). This gives

6666you access to colors more like a color wheel, where all hues are aranged in a

@@ -97,7 +97,7 @@ complement color =

9797 RGBA r g b a -> let (h,s,l) = rgbToHsl r g b

9898 in hsla (h + degrees 180) s l a

9999

100−{-| Extract the the components of a color in the HSL format.

100+{-| Extract the components of a color in the HSL format.

101101-}

102102toHsl : Color -> { hue:Float, saturation:Float, lightness:Float, alpha:Float }

103103toHsl color =

@@ -107,7 +107,7 @@ toHsl color =

107107 let (h,s,l) = rgbToHsl r g b

108108 in { hue=h, saturation=s, lightness=l, alpha=a }

109109

110−{-| Extract the the components of a color in the RGB format.

110+{-| Extract the components of a color in the RGB format.

111111-}

112112toRgb : Color -> { red:Int, green:Int, blue:Int, alpha:Float }

113113toRgb color =

libraries/Debug.elm+32−2

@@ -2,11 +2,16 @@ module Debug where

22{-| This library is for investigating bugs or performance problems. It should

33*not* be used in production code.

44

5−@docs log, trace

5+# Console Debugging

6+@docs log, crash

7+

8+# Time-Travel Debugging

9+@docs watch, watchSummary, trace

610-}

711

812import Graphics.Element (Element)

913import Native.Debug

14+import Native.Error

1015

1116{-| Log a tagged value on the developer console, and then return the value.

1217

@@ -19,6 +24,32 @@ investigating bugs or performance problems.

1924log : String -> a -> a

2025log = Native.Debug.log

2126

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+

2253{-| Watch a particular value in the reactive debugger.

2354-}

2455watch : String -> a -> a

@@ -33,4 +64,3 @@ watchSummary = Native.Debug.watchSummary

3364-}

3465trace : String -> Element -> Element

3566trace = Native.Debug.tracePath

36−

libraries/Dict.elm+2−1

@@ -37,6 +37,7 @@ import Basics (..)

3737import Maybe (..)

3838import Native.Error

3939import List

40+import List ((::))

4041import Native.Utils

4142

4243-- BBlack and NBlack should only be used during the deletion

@@ -248,7 +249,7 @@ reportRemBug msg c lgot rgot =

248249 lgot,

249250 " ",

250251 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"

252253 ]

253254

254255-- Remove the top node from the tree, may leave behind BBlacks

libraries/Either.elm+2−1

@@ -14,8 +14,9 @@ module Either where

1414-}

1515

1616import List

17+import List ((::))

1718

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

1920either an `Int` or a `String`.

2021

2122This 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.

3232

3333import Basics (..)

3434import List

35−import Either (Either, Left, Right)

35+import Either (Either(Left, Right))

3636import Transform2D (Transform2D, identity)

3737import Native.Graphics.Collage

3838import Graphics.Element (Element)

libraries/Graphics/Element.elm+1−1

@@ -41,7 +41,7 @@ import Basics (..)

4141import Native.Utils

4242import List as List

4343import Color (..)

44−import Maybe (Maybe, Just, Nothing)

44+import Maybe ( Maybe(..) )

4545

4646type Properties = {

4747 id : Int,

libraries/Graphics/Input/Field.elm+4−4

@@ -33,8 +33,8 @@ edges all have width 1:

3333uniformly : Int -> Dimensions

3434uniformly n = Dimensions n n n n

3535

36−{-| For setting dimensions of a fields padding or border. The left, right, top,

37−and bottom may all have different sizes. The following example creates

36+{-| For setting dimensions of a field's padding or outline. The left, right,

37+top, and bottom may all have different sizes. The following example creates

3838dimensions such that the left and right are twice as wide as the top and bottom:

3939

4040 myDimensions : Int -> Dimensions

@@ -69,8 +69,8 @@ noHighlight : Highlight

6969noHighlight = Highlight Color.blue 0

7070

7171{-| 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

73−outline that shows up when the field has focus. `outline` describes the line

72+itself using [`Text.Style`](/Text#Style). `highlight` describes the glowing blue

73+highlight that shows up when the field has focus. `outline` describes the line

7474surrounding the text field, and `padding` adds whitespace between the `outline`

7575and the text.

7676

libraries/Keyboard.elm+15−8

@@ -8,7 +8,10 @@ module Keyboard where

88@docs arrows, wasd, directions

99

1010# 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

1215

1316# General Keypresses

1417@docs isDown, keysDown, lastPressed

@@ -50,19 +53,23 @@ wasd = directions 87 83 65 68

5053isDown : KeyCode -> Signal Bool

5154isDown = Native.Keyboard.isDown

5255

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+

5467shift : Signal Bool

5568shift = isDown 16

5669

57−{-| Whether the control key is pressed. -}

58−ctrl : Signal Bool

59−ctrl = isDown 17

60−

61−{-| Whether the space key is pressed. -}

6270space : Signal Bool

6371space = isDown 32

6472

65−{-| Whether the enter key is pressed. -}

6673enter : Signal Bool

6774enter = isDown 13

6875

libraries/List.elm+32−11

@@ -10,16 +10,19 @@ list must have the same type.

1010@docs head, tail, last, filter, take, drop

1111

1212# Putting Lists Together

13−@docs concat, concatMap, join, intersperse, zip, zipWith, repeat

13+@docs concat, join, intersperse, zip, zipWith, repeat

1414

1515# Taking Lists Apart

1616@docs partition, unzip

1717

1818# Folds

19−@docs foldr, foldl, foldr1, foldl1, scanl, scanl1

19+@docs foldr, foldl

20+

21+# Special Maps

22+@docs filterMap, concatMap, indexedMap

2023

2124# Special Folds

22−@docs sum, product, maximum, minimum, all, any, and, or

25+@docs sum, product, maximum, minimum, all, any, foldr1, foldl1, scanl, scanl1

2326

2427# Sorting

2528@docs sort, sortBy, sortWith

@@ -35,6 +38,7 @@ possibly should be approached another way.

3538-}

3639

3740import Basics (..)

41+import Maybe ( Maybe(Just,Nothing) )

3842import Native.List

3943

4044{-| Add an element to the front of a list `(1 :: [2,3] == [1,2,3])` -}

@@ -81,6 +85,15 @@ isEmpty xs =

8185map : (a -> b) -> [a] -> [b]

8286map = Native.List.map

8387

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+

8497{-| Reduce a list from the left: `(foldl (::) [] [1,2,3] == [3,2,1])` -}

8598foldl : (a -> b -> b) -> b -> [a] -> b

8699foldl = Native.List.foldl

@@ -117,6 +130,22 @@ scanl1 = Native.List.scanl1

117130filter : (a -> Bool) -> [a] -> [a]

118131filter = Native.List.filter

119132

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+

120149{-| Determine the length of a list: `(length [1,2,3] == 3)` -}

121150length : [a] -> Int

122151length = Native.List.length

@@ -133,14 +162,6 @@ all = Native.List.all

133162any : (a -> Bool) -> [a] -> Bool

134163any = Native.List.any

135164

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−

144165{-| Concatenate a list of appendable things:

145166

146167 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

22

33{-| Represents an optional value. Maybe it is there, maybe it is not.

44

@@ -8,12 +8,11 @@ module Maybe where

88# Taking Maybes apart

99@docs maybe, isJust, isNothing

1010

11−# Maybes and Lists

12−@docs justs

11+# Map

12+@docs map

1313-}

1414

1515import Basics (not, (.))

16−import List (foldr)

1716

1817{-| The Maybe datatype. Useful when a computation may or may not

1918result in a value (e.g. logarithm is defined only for positive

@@ -27,14 +26,12 @@ function to the associated value.

2726

2827 isPositive : Maybe Int -> Bool

2928 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

3329-}

3430maybe : b -> (a -> b) -> Maybe a -> b

35−maybe b f m = case m of

36− Just v -> f v

37− Nothing -> b

31+maybe b f m =

32+ case m of

33+ Just v -> f v

34+ Nothing -> b

3835

3936{-| Check if a maybe happens to be a `Just`.

4037

@@ -54,12 +51,13 @@ isJust = maybe False (\_ -> True)

5451isNothing : Maybe a -> Bool

5552isNothing = not . isJust

5653

57−cons : Maybe a -> [a] -> [a]

58−cons mx xs = maybe xs (\x -> x :: xs) mx

59−

60−{-| Filters out Nothings and extracts the remaining values.

54+{-| Transform the contents of a `Maybe` with a given function:

6155

62− justs [Just 0, Nothing, Just 5, Just 7] == [0,5,7]

56+ map sqrt (Just 9) == Just 3

57+ map sqrt Nothing == Nothing

6358-}

64−justs : [Maybe a] -> [a]

65−justs = foldr cons []

59+map : (a -> b) -> Maybe a -> Maybe b

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

255255 }

256256

257257 function foldl(f, b, a) {

258− for (var i = 0; i < a.table.length; i++) {

259− b = A2(f, a.height == 0 ? a.table[i] : foldl(f, b, a.table[i]), b);

258+ if (a.height == 0) {

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

260266 }

261267 return b;

262268 }

263269

264270 function foldr(f, b, a) {

265− for (var i = a.table.length; i--; ) {

266− b = A2(f, a.height == 0 ? a.table[i] : foldr(f, b, a.table[i]), b);

271+ if (a.height == 0) {

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

267279 }

268280 return b;

269281 }

@@ -345,9 +357,11 @@ Elm.Native.Array.make = function(elm) {

345357 // TODO: Add support for appending trees of different sizes. Current

346358 // behavior will just rise the lower tree and then append them.

347359 function append(a,b) {

348− if (b.height > a.height) { return append(parentise(a, b.height), b); }

349− if (a.height > b.height) { return append(a, parentise(b, a.height)); }

350− if (a.height == 0) { return append(parentise(a, 1), parentise(b, 1)); }

360+ if (a.table.length == 0) return b;

361+ if (b.table.length == 0) return a;

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

351365

352366 var c = append_(a, b);

353367 if (c[1].table.length > 0) {

libraries/Native/Basics.js+22

@@ -23,6 +23,23 @@ Elm.Native.Basics.make = function(elm) {

2323

2424 function truncate(n) { return n|0; }

2525

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+

2643 var basics = {

2744 div:F2(div),

2845 rem:F2(rem),

@@ -38,6 +55,11 @@ Elm.Native.Basics.make = function(elm) {

3855 atan:Math.atan,

3956 atan2:F2(Math.atan2),

4057

58+ degrees: degrees,

59+ turns: turns,

60+ fromPolar: fromPolar,

61+ toPolar: toPolar,

62+

4163 sqrt:Math.sqrt,

4264 abs:abs,

4365 logBase:F2(logBase),

libraries/Native/Char.js+6−4

@@ -4,6 +4,8 @@ Elm.Native.Char.make = function(elm) {

44 elm.Native.Char = elm.Native.Char || {};

55 if (elm.Native.Char.values) return elm.Native.Char.values;

66

7+ var Utils = Elm.Native.Utils.make(elm);

8+

79 function isBetween(lo,hi) { return function(chr) {

810 var c = chr.charCodeAt(0);

911 return lo <= c && c <= hi;

@@ -16,10 +18,10 @@ Elm.Native.Char.make = function(elm) {

1618 return elm.Native.Char.values = {

1719 fromCode : function(c) { return String.fromCharCode(c); },

1820 toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

19− toUpper : function(c) { return c.toUpperCase(); },

20− toLower : function(c) { return c.toLowerCase(); },

21− toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

22− toLocaleLower : function(c) { return c.toLocaleLowerCase(); },

21+ toUpper : function(c) { return Utils.chr(c.toUpperCase()); },

22+ toLower : function(c) { return Utils.chr(c.toLowerCase()); },

23+ toLocaleUpper : function(c) { return Utils.chr(c.toLocaleUpperCase()); },

24+ toLocaleLower : function(c) { return Utils.chr(c.toLocaleLowerCase()); },

2325 isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),

2426 isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),

2527 isDigit : isDigit,

libraries/Native/Graphics/Input.js+84−52

@@ -21,46 +21,67 @@ Elm.Native.Graphics.Input.make = function(elm) {

2121 return { _:{}, signal:signal, handle:signal };

2222 }

2323

24− function renderDropDown(signal, values) {

25− return function(_) {

26− var entries = List.toArray(values);

27−

28− var drop = newNode('select');

29− drop.style.border = '0 solid';

30− drop.style.pointerEvents = 'auto';

31− for (var i = 0; i < entries.length; ++i) {

32− var option = newNode('option');

33− var name = entries[i]._0;

34− option.value = name;

35− option.innerHTML = name;

36− drop.appendChild(option);

37− }

38− drop.addEventListener('change', function() {

39− elm.notify(signal.id, entries[drop.selectedIndex]._1);

40− });

41−

42− var t = drop.cloneNode(true);

43− t.style.visibility = "hidden";

24+ function renderDropDown(model) {

25+ var drop = newNode('select');

26+ drop.style.border = '0 solid';

27+ drop.style.pointerEvents = 'auto';

28+ drop.style.display = 'block';

29+

30+ drop.elm_signal = model.signal;

31+ drop.elm_values = List.toArray(model.values);

32+ var values = drop.elm_values;

33+

34+ for (var i = 0; i < values.length; ++i) {

35+ var option = newNode('option');

36+ var name = values[i]._0;

37+ option.value = name;

38+ option.innerHTML = name;

39+ drop.appendChild(option);

40+ }

41+ drop.addEventListener('change', function() {

42+ elm.notify(drop.elm_signal.id, drop.elm_values[drop.selectedIndex]._1);

43+ });

4444

45− elm.node.appendChild(t);

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− };

45+ return drop;

5246 }

5347

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

5573 }

5674

5775 function dropDown(signal, values) {

5876 return A3(newElement, 100, 24, {

5977 ctor: 'Custom',

6078 type: 'DropDown',

61− render: renderDropDown(signal,values),

79+ render: renderDropDown,

6280 update: updateDropDown,

63− model: {}

81+ model: {

82+ signal: signal,

83+ values: values

84+ }

6485 });

6586 }

6687

@@ -105,52 +126,63 @@ Elm.Native.Graphics.Input.make = function(elm) {

105126 btn.elm_hover = Render.render(model.hover);

106127 btn.elm_down = Render.render(model.down);

107128

108− function replace(node) {

109− if (node !== btn.firstChild) {

110− btn.replaceChild(node, btn.firstChild);

111− }

129+ btn.elm_up.style.display = 'block';

130+ btn.elm_hover.style.display = 'none';

131+ btn.elm_down.style.display = 'none';

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';

112141 }

142+

113143 var overCount = 0;

114144 function over(e) {

115145 if (overCount++ > 0) return;

116− replace(btn.elm_hover);

146+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

117147 }

118148 function out(e) {

119149 if (btn.contains(e.toElement || e.relatedTarget)) return;

120150 overCount = 0;

121− replace(btn.elm_up);

151+ swap(btn.elm_up, btn.elm_down, btn.elm_hover);

122152 }

123153 function up() {

124− replace(btn.elm_hover);

154+ swap(btn.elm_hover, btn.elm_down, btn.elm_up);

125155 elm.notify(btn.elm_signal.id, btn.elm_value);

126156 }

127157 function down() {

128− replace(btn.elm_down);

158+ swap(btn.elm_down, btn.elm_hover, btn.elm_up);

129159 }

160+

130161 btn.addEventListener('mouseover', over);

131162 btn.addEventListener('mouseout' , out);

132163 btn.addEventListener('mousedown', down);

133164 btn.addEventListener('mouseup' , up);

134165

135− btn.appendChild(btn.elm_up);

136−

137166 return btn;

138167 }

139168

140169 function updateCustomButton(node, oldModel, newModel) {

141− var signal = newModel.signal;

142− node.elm_up.elm_signal = signal;

143− node.elm_hover.elm_signal = signal;

144− node.elm_down.elm_signal = signal;

145−

146− var value = newModel.value;

147− node.elm_up.elm_value = value;

148− node.elm_hover.elm_value = value;

149− node.elm_down.elm_value = value;

150−

151− Render.update(node.elm_up, oldModel.up, newModel.up)

152− Render.update(node.elm_hover, oldModel.hover, newModel.hover)

153− Render.update(node.elm_down, oldModel.down, newModel.down)

170+ node.elm_signal = newModel.signal;

171+ node.elm_value = newModel.value;

172+

173+ var kids = node.childNodes;

174+ var styleUp = kids[0].style.display;

175+ var styleHover = kids[1].style.display;

176+ var styleDown = kids[2].style.display;

177+

178+ Render.update(kids[0], oldModel.up, newModel.up);

179+ Render.update(kids[1], oldModel.hover, newModel.hover);

180+ Render.update(kids[2], oldModel.down, newModel.down);

181+

182+ var kids = node.childNodes;

183+ kids[0].style.display = styleUp;

184+ kids[1].style.display = styleHover;

185+ kids[2].style.display = styleDown;

154186 }

155187

156188 function max3(a,b,c) {

libraries/Native/Signal/Keyboard.js+138−107

@@ -1,120 +1,151 @@

11Elm.Native.Keyboard = {};

22Elm.Native.Keyboard.make = function(elm) {

33

4− elm.Native = elm.Native || {};

5− elm.Native.Keyboard = elm.Native.Keyboard || {};

6− if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7−

8− // Duplicated from Native.Signal

9− function send(node, timestep, changed) {

10− var kids = node.kids;

11− for (var i = kids.length; i--; ) {

12− kids[i].recv(timestep, changed, node.id);

4+ elm.Native = elm.Native || {};

5+ elm.Native.Keyboard = elm.Native.Keyboard || {};

6+ if (elm.Native.Keyboard.values) return elm.Native.Keyboard.values;

7+

8+ // Duplicated from Native.Signal

9+ function send(node, timestep, changed) {

10+ var kids = node.kids;

11+ for (var i = kids.length; i--; ) {

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

1342 }

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 NS = Elm.Native.Signal.make(elm);

21− var downEvents = NS.input(0);

22− var upEvents = NS.input(0);

23− var blurEvents = NS.input(0);

24−

25− elm.addListener([downEvents.id], document, 'keydown', function down(e) {

26− elm.notify(downEvents.id, e.keyCode);

27− });

28−

29− elm.addListener([upEvents.id], document, 'keyup', function up(e) {

30− elm.notify(upEvents.id, e.keyCode);

31− });

32−

33− elm.addListener([blurEvents.id], document, 'blur', function blur(e) {

34− elm.notify(blurEvents.id, NList.Nil);

35− });

36−

37− function KeyMerge(down, up, blur) {

38− this.nodeType = "merge";

39−

40− var args = [down,up,blur];

41− this.id = Utils.guid();

42− // Ignore starting values here

43− this.value = NList.Nil

44− this.kids = [];

45−

46− var n = args.length;

47− var count = 0;

48− var isChanged = false;

49−

50− this.recv = function(timestep, changed, parentID) {

51− ++count;

52− if (changed) {

53− // We know this a change must only be one of the following cases

54− if (parentID === down.id && !(NList.member(down.value)(this.value))) {

55− isChanged = true;

56− this.value = NList.Cons(down.value, this.value);

57− }

58− if (parentID === up.id) {

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;

43+ var emptyState = state(false, false, NList.Nil);

44+

45+ function KeyMerge(down, up, blur) {

46+ var args = [down,up,blur];

47+ this.id = Utils.guid();

48+ // Ignore starting values here

49+ this.value = emptyState;

50+ this.kids = [];

51+

52+ var n = args.length;

53+ var count = 0;

54+ var isChanged = false;

55+

56+ this.recv = function(timestep, changed, parentID) {

57+ ++count;

58+ if (changed) {

59+ // We know this a change must only be one of the following cases

60+ if (parentID === down.id && !A2(NList.member, down.value.keyCode, this.value.keyCodes)) {

61+ isChanged = true;

62+ var v = down.value;

63+ var newCodes = NList.Cons(v.keyCode, this.value.keyCodes);

64+ this.value = state(v.altKey, v.metaKey, newCodes);

65+ }

66+ else if (parentID === up.id) {

67+ isChanged = true;

68+ var v = up.value;

69+ var notEq = function(kc) { return kc !== v.keyCode };

70+ var newCodes = A2(NList.filter, notEq, this.value.keyCodes);

71+ this.value = state(v.altKey, v.metaKey, newCodes);

72+ }

73+ else if (parentID === blur.id) {

74+ isChanged = true;

75+ this.value = emptyState;

76+ }

77+ }

78+ if (count == n) {

79+ send(this, timestep, isChanged);

80+ isChanged = false;

81+ count = 0;

82+ }

83+ };

84+

85+ for (var i = n; i--; ) {

86+ args[i].kids.push(this);

87+ args[i].defaultNumberOfKids += 1;

6688 }

67− }

68− if (count == n) {

69− send(this, timestep, isChanged);

70− isChanged = false;

71− count = 0;

72− }

73− };

89+ }

7490

75− for (var i = n; i--; ) { args[i].kids.push(this); }

76−

77− }

78−

79− var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));

80−

81− function keySignal(f) {

82− var signal = A2(Signal.lift, f, keysDown);

83− // must set the default number of kids to make it possible to filter

84− // these signals if they are not actually used.

85− keysDown.defaultNumberOfKids += 1;

86− signal.defaultNumberOfKids = 1;

87− var filtered = Signal.dropRepeats(signal)

88− filtered.defaultNumberOfKids = 0;

89− return filtered;

90− }

91−

92− function dir(up, down, left, right) {

93− function f(ks) {

94− var x = 0, y = 0;

95− while (ks.ctor === "::") {

96− switch (ks._0) {

97− case left : --x; break;

98− case right: ++x; break;

99− case up : ++y; break;

100− case down : --y; break;

91+ var keyMerge = new KeyMerge(downEvents,upEvents,blurEvents);

92+

93+ // select a part of a keyMerge and dropRepeats the result

94+ function keySignal(f) {

95+ var signal = A2(Signal.lift, f, keyMerge);

96+ // must set the default number of kids to make it possible to filter

97+ // these signals if they are not actually used.

98+ keyMerge.defaultNumberOfKids += 1;

99+ signal.defaultNumberOfKids = 1;

100+ var filtered = Signal.dropRepeats(signal);

101+ filtered.defaultNumberOfKids = 0;

102+ return filtered;

103+ }

104+

105+ // break keyMerge into parts

106+ var keysDown = keySignal(function getKeyCodes(v) {

107+ return v.keyCodes;

108+ });

109+ var alt = keySignal(function getKeyCodes(v) {

110+ return v.alt;

111+ });

112+ var meta = keySignal(function getKeyCodes(v) {

113+ return v.meta;

114+ });

115+

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

101130 }

102− ks = ks._1;

103− }

104− return { _:{}, x:x, y:y };

131+ return keySignal(toDirections);

105132 }

106− return keySignal(f);

107− }

108133

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

110139

111− var lastPressed = downEvents;

140+ var lastPressed = downEvents;

112141

113− return elm.Native.Keyboard.values = {

114− isDown:is,

115− directions:F4(dir),

116− keysDown:keysDown,

117− lastPressed:lastPressed

118− };

142+ return elm.Native.Keyboard.values = {

143+ isDown:is,

144+ alt: alt,

145+ meta: meta,

146+ directions:F4(dir),

147+ keysDown:keysDown,

148+ lastPressed:lastPressed

149+ };

119150

120151};

libraries/Native/Signal/WebSocket.js+1−1

@@ -9,7 +9,7 @@ Elm.Native.WebSocket.make = function(elm) {

99 var List = Elm.Native.List.make(elm);

1010

1111 function open(url, outgoing) {

12− var incoming = Signal.constant(List.Nil);

12+ var incoming = Signal.constant("");

1313 var ws = new WebSocket(url);

1414

1515 var pending = [];

libraries/Signal.elm+1−1

@@ -30,7 +30,7 @@ the `Time` library.

3030-}

3131

3232import Native.Signal

33−import List (foldr)

33+import List (foldr, (::))

3434import Basics (fst, snd, not)

3535

3636data Signal a = Signal

libraries/String.elm+3−2

@@ -123,6 +123,7 @@ split = Native.String.split

123123

124124{-| Put many strings together with a given separator.

125125

126+ join "a" ["H","w","ii","n"] == "Hawaiian"

126127 join " " ["cat","dog","cow"] == "cat dog cow"

127128 join "/" ["home","evan","Desktop"] == "home/evan/Desktop"

128129-}

@@ -204,7 +205,7 @@ trim = Native.String.trim

204205trimLeft : String -> String

205206trimLeft = Native.String.trimLeft

206207

207−{-| Get rid of whitespace on the left of a string.

208+{-| Get rid of whitespace on the right of a string.

208209

209210 trimRight " hats \n" == " hats"

210211-}

@@ -220,7 +221,7 @@ words = Native.String.words

220221

221222{-| Break a string into lines, splitting on newlines.

222223

223− lines "How are you?\nGood? == ["How are you?", "Good?"]

224+ lines "How are you?\nGood?" == ["How are you?", "Good?"]

224225-}

225226lines : String -> [String]

226227lines = Native.String.lines

libraries/Text.elm+2−2

@@ -34,7 +34,7 @@ import Basics (..)

3434import String

3535import Color (Color, black)

3636import Graphics.Element (Element, Three, Pos, ElementPrim, Properties)

37−import Maybe (Maybe, Nothing)

37+import Maybe (Maybe(Nothing))

3838import Native.Show

3939import Native.Text

4040

@@ -212,7 +212,7 @@ markdown = Native.Text.markdown

212212{-| Convert anything to its textual representation and make it displayable in

213213the browser:

214214

215− asText value = text (monospace (show value))

215+ asText value = leftAligned (monospace (toText (show value)))

216216

217217Excellent for debugging.

218218-}

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

26{-| A library for performing [2D matrix transformations][affine].

37It is used primarily with the `groupTransform` function from `Graphics.Collage` and

48allows 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.

88-}

99

1010import Signal (Signal)

11−import Basics (String)

1211import Native.WebSocket

1312

1413{-| 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) {

6363 throw new Error(

6464 'The notify function has been called synchronously!\n' +

6565 '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');

6767 }

6868 updateInProgress = true;

6969 var timestep = timer.now();

@@ -258,8 +258,9 @@ function initGraphics(elm, Module) {

258258

259259 // set up updates so that the DOM is adjusted as necessary.

260260 var savedScene = currentScene;

261+ var previousDrawId = 0;

261262 function domUpdate(newScene) {

262− ElmRuntime.draw(function(_) {

263+ previousDrawId = ElmRuntime.draw(previousDrawId, function(_) {

263264 Render.update(elm.node.firstChild, savedScene, newScene);

264265 if (elm.Native.Window) elm.Native.Window.values.resizeIfNeeded();

265266 savedScene = newScene;

runtime/Render/Element.js+75−61

@@ -7,40 +7,45 @@ var newElement = Utils.newElement, colorToCss = Utils.colorToCss,

77 addTransform = Utils.addTransform, removeTransform = Utils.removeTransform,

88 fromList = Utils.fromList, eq = Utils.eq;

99

10−function setProps(elem, e) {

10+function setProps(elem, node) {

1111 var props = elem.props;

12+

1213 var element = elem.element;

1314 var width = props.width - (element.adjustWidth || 0);

1415 var height = props.height - (element.adjustHeight || 0);

15− e.style.width = (width |0) + 'px';

16− e.style.height = (height|0) + 'px';

16+ node.style.width = (width |0) + 'px';

17+ node.style.height = (height|0) + 'px';

18+

1719 if (props.opacity !== 1) {

18− e.style.opacity = props.opacity;

20+ node.style.opacity = props.opacity;

1921 }

22+

2023 if (props.color.ctor === 'Just') {

21− e.style.backgroundColor = colorToCss(props.color._0);

24+ node.style.backgroundColor = colorToCss(props.color._0);

2225 }

23− if (props.tag !== '') { e.id = props.tag; }

24− if (props.href !== '') {

25− var a = newElement('a');

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

26+

27+ if (props.tag !== '') {

28+ node.id = props.tag;

3629 }

30+

3731 if (props.hover.ctor !== '_Tuple0') {

38− addHover(e, props.hover);

32+ addHover(node, props.hover);

3933 }

34+

4035 if (props.click.ctor !== '_Tuple0') {

41− addClick(e, props.click);

36+ addClick(node, props.click);

4237 }

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;

4449}

4550

4651function addClick(e, handler) {

@@ -354,61 +359,70 @@ function update(node, curr, next) {

354359}

355360

356361function updateProps(node, curr, next) {

357− var props = next.props;

358− var currP = curr.props;

359− var e = node;

362+ var nextProps = next.props;

363+ var currProps = curr.props;

364+

360365 var element = next.element;

361− var width = props.width - (element.adjustWidth || 0);

362− var height = props.height - (element.adjustHeight || 0);

363− if (width !== currP.width) {

364− e.style.width = (width|0) + 'px';

366+ var width = nextProps.width - (element.adjustWidth || 0);

367+ var height = nextProps.height - (element.adjustHeight || 0);

368+ if (width !== currProps.width) {

369+ node.style.width = (width|0) + 'px';

370+ }

371+ if (height !== currProps.height) {

372+ node.style.height = (height|0) + 'px';

365373 }

366− if (height !== currP.height) {

367− e.style.height = (height|0) + 'px';

374+

375+ if (nextProps.opacity !== currProps.opacity) {

376+ node.style.opacity = nextProps.opacity;

368377 }

369− if (props.opacity !== currP.opacity) {

370− e.style.opacity = props.opacity;

378+

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;

371384 }

372− var nextColor = (props.color.ctor === 'Just' ?

373− colorToCss(props.color._0) : '');

374− if (e.style.backgroundColor !== nextColor) {

375− e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);

385+

386+ if (nextProps.tag !== currProps.tag) {

387+ node.id = nextProps.tag;

376388 }

377− if (props.tag !== currP.tag) { e.id = props.tag; }

378− if (props.href !== currP.href) {

379− if (currP.href === '') {

380− var a = newElement('a');

381− a.href = props.href;

382− a.style.width = '100%';

383− a.style.height = '100%';

384− a.style.top = 0;

385− a.style.left = 0;

386− a.style.display = 'block';

387− a.style.position = 'absolute';

388− e.style.position = 'relative';

389− a.style.pointerEvents = 'auto';

390− e.appendChild(a);

389+

390+ if (nextProps.href !== currProps.href) {

391+ if (currProps.href === '') {

392+ // add a surrounding href

393+ var anchor = newElement('a');

394+ anchor.href = nextProps.href;

395+ anchor.style.display = 'block';

396+ anchor.style.pointerEvents = 'auto';

397+

398+ node.parentNode.replaceChild(anchor, node);

399+ anchor.appendChild(node);

400+ } else if (nextProps.href === '') {

401+ // remove the surrounding href

402+ var anchor = node.parentNode;

403+ anchor.parentNode.replaceChild(node, anchor);

391404 } else {

392− node.lastNode.href = props.href;

405+ // just update the link

406+ node.parentNode.href = nextProps.href;

393407 }

394408 }

395409

396410 // update hover handlers

397− if (props.hover.ctor === '_Tuple0') {

398− removeHover(e);

399− } else if (e.elm_hover_handler) {

400− e.elm_hover_handler = props.hover;

411+ if (nextProps.hover.ctor === '_Tuple0') {

412+ removeHover(node);

413+ } else if (node.elm_hover_handler) {

414+ node.elm_hover_handler = nextProps.hover;

401415 } else {

402− addHover(e, props.hover);

416+ addHover(node, nextProps.hover);

403417 }

404418

405419 // update click handlers

406− if (props.click.ctor === '_Tuple0') {

407− removeClick(e);

408− } else if (e.elm_click_handler) {

409− e.elm_click_handler = props.click;

420+ if (nextProps.click.ctor === '_Tuple0') {

421+ removeClick(node);

422+ } else if (node.elm_click_handler) {

423+ node.elm_click_handler = nextProps.click;

410424 } else {

411− addClick(e, props.click);

425+ addClick(node, nextProps.click);

412426 }

413427}

414428

runtime/Utils.js+14−6

@@ -32,7 +32,13 @@ ElmRuntime.filterDeadInputs = function(inputs) {

3232 return temp;

3333};

3434

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

3642var vendors = ['ms', 'moz', 'webkit', 'o'];

3743var win = typeof window !== 'undefined' ? window : {};

3844for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

@@ -42,13 +48,15 @@ for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

4248}

4349

4450if (win.requestAnimationFrame && win.cancelAnimationFrame) {

45− var previous = 0;

46− ElmRuntime.draw = function(callback) {

47− win.cancelAnimationFrame(previous);

48− previous = win.requestAnimationFrame(callback);

51+ ElmRuntime.draw = function(previousRequestID, callback) {

52+ win.cancelAnimationFrame(previousRequestID);

53+ return win.requestAnimationFrame(callback);

4954 };

5055} else {

51− ElmRuntime.draw = function(callback) { callback(); };

56+ ElmRuntime.draw = function(previousRequestID, callback) {

57+ callback();

58+ return previousRequestID;

59+ };

5260}

5361

5462}());

tests/compiler/Tests/Compiler.hs+27−23

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

1−module Tests.Compiler (compilerTests)

2− where

1+module Tests.Compiler (compilerTests) where

32

43import Data.Functor ((<$>))

54import Data.Traversable (traverse)

@@ -13,31 +12,36 @@ import Text.Parsec (ParseError)

1312import Elm.Internal.Utils as Elm

1413

1514compilerTests :: Test

16−compilerTests = buildTest $ do

17− goods <- mkTests goodCompile =<< getElms "good"

18− bads <- mkTests badCompile =<< getElms "bad"

19− return $ testGroup "Compile Tests"

20− [

21− testGroup "Good Tests" goods

22− , testGroup "Bad Tests" bads

23− ]

24−

25− where getElms :: FilePath -> IO [FilePath]

26− getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

27−

28− mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

29− mkTests h = traverse setupTest

30− where setupTest f = testCase f . mkCompileTest h <$> readFile f

31−

32− testsDir = "tests" </> "test-files"

15+compilerTests =

16+ buildTest $ do

17+ goods <- mkTests goodCompile =<< getElms "good"

18+ bads <- mkTests badCompile =<< getElms "bad"

19+ return $ testGroup "Compile Tests"

20+ [ testGroup "Good Tests" goods

21+ , testGroup "Bad Tests" bads

22+ ]

23+ where

24+ getElms :: FilePath -> IO [FilePath]

25+ getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

26+

27+ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

28+ mkTests h = traverse setupTest

29+ where setupTest f = testCase f . mkCompileTest h <$> readFile f

30+

31+ testsDir :: FilePath

32+ testsDir = "tests" </> "compiler" </> "test-files"

3333

3434goodCompile :: Either String String -> Assertion

35−goodCompile (Left err) = assertFailure err

36−goodCompile (Right _) = assertBool "" True

35+goodCompile result =

36+ case result of

37+ Left err -> assertFailure err

38+ Right _ -> assertBool "" True

3739

3840badCompile :: Either String String -> Assertion

39−badCompile (Left _) = assertBool "" True

40−badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

41+badCompile result =

42+ case result of

43+ Left _ -> assertBool "" True

44+ Right _ -> assertFailure "Compilation succeeded but should have failed"

4145

4246mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

4347 -> String -- ^ File Contents

tests/compiler/Tests/Property.hs+23−22

@@ -9,11 +9,12 @@ import Test.QuickCheck

99import Text.Parsec.Combinator (eof)

1010import Text.PrettyPrint as P

1111

12−import SourceSyntax.Literal as Lit

13−import qualified SourceSyntax.Pattern as P

14−import SourceSyntax.PrettyPrint (Pretty, pretty)

15−import Parse.Helpers (IParser, iParse)

16−import Parse.Literal (literal)

12+import AST.Literal as Lit

13+import qualified AST.Pattern as P

14+import qualified AST.Variable as V

15+import AST.PrettyPrint (Pretty, pretty)

16+import Parse.Helpers (IParser, iParse)

17+import Parse.Literal (literal)

1718import qualified Parse.Pattern as Pat (expr)

1819import qualified Parse.Type as Type (expr)

1920import Tests.Property.Arbitrary

@@ -21,8 +22,7 @@ import Tests.Property.Arbitrary

2122propertyTests :: Test

2223propertyTests =

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

2626 , testProperty "Literal test" $ prop_parse_print literal

2727 , testProperty "Pattern test" $ prop_parse_print Pat.expr

2828 , testProperty "Type test" $ prop_parse_print Type.expr

@@ -31,21 +31,22 @@ propertyTests =

3131 where

3232 -- This test was autogenerated from the Pattern test and should be

3333 -- left in all its ugly glory.

34− longPat = P.Data "I" [ P.Literal (Lit.Chr '+')

35− , P.Record

36− [ "q7yclkcm7k_ikstrczv_"

37− , "wQRv6gKsvvkjw4b5F"

38− ,"c9'eFfhk9FTvsMnwF_D"

39− ,"yqxhEkHvRFwZ"

40− ,"o"

41− ,"nbUlCn3y3NnkVoxhW"

42− ,"iJ0MNy3KZ_lrs"

43− ,"ug"

44− ,"sHHsX"

45− ,"mRKs9d"

46− ,"o2KiCX5'ZRzHJfRi8" ]

47− , P.Var "su'BrrbPUK6I33Eq"

48− ]

34+ longPat = P.Data (V.Raw "I")

35+ [ P.Literal (Lit.Chr '+')

36+ , P.Record

37+ [ "q7yclkcm7k_ikstrczv_"

38+ , "wQRv6gKsvvkjw4b5F"

39+ ,"c9'eFfhk9FTvsMnwF_D"

40+ ,"yqxhEkHvRFwZ"

41+ ,"o"

42+ ,"nbUlCn3y3NnkVoxhW"

43+ ,"iJ0MNy3KZ_lrs"

44+ ,"ug"

45+ ,"sHHsX"

46+ ,"mRKs9d"

47+ ,"o2KiCX5'ZRzHJfRi8" ]

48+ , P.Var "su'BrrbPUK6I33Eq"

49+ ]

4950

5051prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

5152prop_parse_print p x =

tests/compiler/Tests/Property/Arbitrary.hs+21−12

@@ -8,9 +8,14 @@ import Test.QuickCheck.Gen

88import qualified Data.Set as Set

99import qualified Parse.Helpers (reserveds)

1010

11−import qualified SourceSyntax.Literal as L

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Type as T

11+import qualified AST.Literal as L

12+import qualified AST.Pattern as P

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

1419

1520instance Arbitrary L.Literal where

1621 arbitrary =

@@ -41,10 +46,10 @@ genVector n generator = do

4146 let m = n `div` (len + 1)

4247 vectorOf len $ generator m

4348

44−instance Arbitrary P.Pattern where

49+instance Arbitrary v => Arbitrary (P.Pattern v) where

4550 arbitrary = sized pat

4651 where

47− pat :: Int -> Gen P.Pattern

52+ pat :: (Arbitrary v) => Int -> Gen (P.Pattern v)

4853 pat n =

4954 oneof

5055 [ pure P.Anything

@@ -52,7 +57,7 @@ instance Arbitrary P.Pattern where

5257 , P.Record <$> (listOf1 lowVar)

5358 , P.Literal <$> arbitrary

5459 , P.Alias <$> lowVar <*> pat (n-1)

55− , P.Data <$> capVar <*> genVector n pat

60+ , P.Data <$> arbitrary <*> genVector n pat

5661 ]

5762

5863 shrink pat =

@@ -61,7 +66,7 @@ instance Arbitrary P.Pattern where

6166 P.Var v -> P.Var <$> shrinkWHead v

6267 P.Literal l -> P.Literal <$> shrink l

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

6570 P.Record fs ->

6671 P.Record <$> filter (all notNull) (filter notNull (shrink fs))

6772 where

@@ -71,29 +76,33 @@ shrinkWHead :: Arbitrary a => [a] -> [[a]]

7176shrinkWHead [] = error "Should be nonempty"

7277shrinkWHead (x:xs) = (x:) <$> shrink xs

7378

74−instance Arbitrary T.Type where

79+instance Arbitrary v => Arbitrary (T.Type v) where

7580 arbitrary = sized tipe

7681 where

77− tipe :: Int -> Gen T.Type

82+ tipe :: Arbitrary v => Int -> Gen (T.Type v)

7883 tipe n =

7984 let depthTipe = tipe =<< choose (0,n)

8085 field = (,) <$> lowVar <*> depthTipe

8186 fields = genVector n (\m -> (,) <$> lowVar <*> tipe m)

8287 fields1 = (:) <$> field <*> fields

88+ depthTipes = (:) <$> depthTipe <*> genVector n tipe

8389 in

8490 oneof

8591 [ T.Lambda <$> depthTipe <*> depthTipe

8692 , T.Var <$> lowVar

87− , T.Data <$> capVar <*> genVector n tipe

93+ , T.Type <$> arbitrary

94+ , T.App <$> (T.Type <$> arbitrary) <*> depthTipes

8895 , T.Record <$> fields <*> pure Nothing

89− , T.Record <$> fields1 <*> (Just <$> lowVar)

96+ , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)

9097 ]

9198

9299 shrink tipe =

93100 case tipe of

94101 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

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

97106 T.Record fs t -> map snd fs ++ record

98107 where

99108 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

1919 unless ("jsdom" `isInfixOf` out) $ runCmd "npm" ["install","jsdom"]

2020

2121 -- setup actual library tests

22− setCurrentDirectory $ top </> "tests" </> "libraries"

23− let localCompiler = joinPath [ top, "dist", "build", "elm", "elm" ]

22+ let localCompiler = joinPath [ "dist", "build", "elm", "elm" ]

2423 runCmd localCompiler [ "--make"

2524 , "--only-js"

26− , "--src-dir=" ++ top </> "automaton"

27− , "--src-dir=" ++ top </> "IO"

28− , "--src-dir=" ++ top </> "Elm-Test"

29− , "Test.elm"

25+ , "--src-dir=IO"

26+ , "--src-dir=Elm-Test"

27+ , "--src-dir=" ++ "tests" </> "libraries"

28+ , testFile <.> "elm"

3029 ]

3130

3231 -- run tests

33− let ioScript s = top </> "IO" </> s

34− files = [ ioScript "prescript.js"

32+ let files = [ "IO" </> "share" </> "prescript.js"

3533 , Elm.runtime

36− , "build" </> "Test.js"

37− , ioScript "handler.js"

34+ , "build" </> testFile <.> "js"

35+ , "IO" </> "share" </> "handler.js"

3836 ]

37+ testRunner = "build" </> "TestRunner.js"

3938 exe <- readProcess "cat" files ""

40− writeFile "exe.js" exe

41− exitWith =<< waitForProcess =<< (runCommand "node exe.js")

39+ writeFile testRunner exe

40+ exitCode <- rawSystem "node" [testRunner]

41+ removeDirectoryRecursive "cache"

42+ removeDirectoryRecursive "build"

43+ exitWith exitCode

44+ where

45+ testFile = "tests" </> "libraries" </> "Test"

4246

4347runCmd :: String -> [String] -> IO ()

4448runCmd cmd args = do

4549 putStrLn (cmd ++ " " ++ unwords args)

46− (exitCode, _stdout, stderr) <- readProcessWithExitCode cmd args ""

50+ (exitCode, stdout, stderr) <- readProcessWithExitCode cmd args ""

51+ putStr stdout

52+ putStr stderr

4753 case exitCode of

4854 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

44import ElmTest.Run as R

55import ElmTest.Runner.Console (runDisplay)

66import ElmTest.Test (..)

7−

87import IO.IO (..)

98import IO.Runner (Request, Response)

109import IO.Runner as Run

1110

1211import Test.Array as Array

12+import Test.Char as Char

1313import Test.Dict as Dict

1414import Test.Equality as Equality

1515import Test.List as List

@@ -20,6 +20,7 @@ import Test.Trampoline as Trampoline

2020tests : Test

2121tests = suite "Elm Standard Library Tests"

2222 [ Array.tests

23+ , Char.tests

2324 , Dict.tests

2425 , Equality.tests

2526 , List.tests

@@ -31,10 +32,7 @@ tests = suite "Elm Standard Library Tests"

3132console : IO ()

3233console = runDisplay tests

3334

34−port requests : Signal [{ mPut : Maybe String

35− , mExit : Maybe Int

36− , mGet : Bool

37− }]

35+port requests : Signal Request

3836port requests = Run.run responses console

3937

40−port responses : Signal (Maybe String)

38+port responses : Signal Response

tests/libraries/Test/Array.elm+5−1

@@ -26,6 +26,8 @@ tests =

2626 , test "length - Long" <| assertEqual 10000 (Array.length (Array.repeat 10000 0))

2727 , test "push" <| assertEqual (Array.fromList [1,2,3]) (Array.push 3 (Array.fromList [1,2]))

2828 , 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))

2931 ]

3032 getAndSetTests = suite "Get and Set"

3133 [ test "get" <| assertEqual (Just 2) (Array.get 1 (Array.fromList [3,2,1]))

@@ -48,9 +50,11 @@ tests =

4850 [ test "map" <| assertEqual (Array.fromList [1,2,3]) (Array.map sqrt (Array.fromList [1,4,9]))

4951 , test "indexedMap 1" <| assertEqual (Array.fromList [0,5,10]) (Array.indexedMap (*) (Array.fromList [5,5,5]))

5052 , 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))

5255 , test "foldr 1" <| assertEqual 15 (Array.foldr (+) 0 (Array.repeat 3 5))

5356 , 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]))

5458 , test "filter" <| assertEqual (Array.fromList [2,4,6]) (Array.filter (\x -> x `mod` 2 == 0) (Array.fromList [1..6]))

5559 ]

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

11module Test.String (tests) where

22

33import List

4−import String (..)

4+import String

55

66import ElmTest.Assertion (..)

77import ElmTest.Test (..)

@@ -9,29 +9,29 @@ import ElmTest.Test (..)

99tests : Test

1010tests =

1111 let simpleTests = suite "Simple Stuff"

12− [ test "is empty" <| assert (isEmpty "")

13− , test "is not empty" <| assert (not (isEmpty ("the world")))

14− , test "length" <| assertEqual 11 (length "innumerable")

15− , test "endsWith" (assert <| endsWith "ship" "spaceship")

16− , test "reverse" <| assertEqual "desserts" (reverse "stressed")

17− , test "repeat" <| assertEqual "hahaha" (repeat 3 "ha")

12+ [ test "is empty" <| assert (String.isEmpty "")

13+ , test "is not empty" <| assert (not (String.isEmpty ("the world")))

14+ , test "length" <| assertEqual 11 (String.length "innumerable")

15+ , test "endsWith" (assert <| String.endsWith "ship" "spaceship")

16+ , test "reverse" <| assertEqual "desserts" (String.reverse "stressed")

17+ , test "repeat" <| assertEqual "hahaha" (String.repeat 3 "ha")

1818 ]

1919

2020 combiningTests = suite "Combining Strings"

21− [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (uncons "abc")

22− , test "uncons empty" <| assertEqual Nothing (uncons "")

23− , test "append 1" <| assertEqual "butterfly" (append "butter" "fly")

24− , test "append 2" <| assertEqual "butter" (append "butter" "")

25− , test "append 3" <| assertEqual "butter" (append "" "butter")

21+ [ test "uncons non-empty" <| assertEqual (Just ('a',"bc")) (String.uncons "abc")

22+ , test "uncons empty" <| assertEqual Nothing (String.uncons "")

23+ , test "append 1" <| assertEqual "butterfly" (String.append "butter" "fly")

24+ , test "append 2" <| assertEqual "butter" (String.append "butter" "")

25+ , test "append 3" <| assertEqual "butter" (String.append "" "butter")

2626 , test "concat" <| assertEqual "nevertheless" (concat ["never","the","less"])

27− , test "split commas" <| assertEqual ["cat","dog","cow"] (split "," "cat,dog,cow")

28− , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (split "/" "home/steve/Desktop/")

29− , test "join spaces" <| assertEqual "cat dog cow" (join " " ["cat","dog","cow"])

30− , test "join slashes" <| assertEqual "home/steve/Desktop" (join "/" ["home","steve","Desktop"])

31− , test "slice 1" <| assertEqual "c" (slice 2 3 "abcd")

32− , test "slice 2" <| assertEqual "abc" (slice 0 3 "abcd")

33− , test "slice 3" <| assertEqual "abc" (slice 0 -1 "abcd")

34− , test "slice 4" <| assertEqual "cd" (slice -2 4 "abcd")

27+ , test "split commas" <| assertEqual ["cat","dog","cow"] (String.split "," "cat,dog,cow")

28+ , test "split slashes"<| assertEqual ["home","steve","Desktop", ""] (String.split "/" "home/steve/Desktop/")

29+ , test "join spaces" <| assertEqual "cat dog cow" (String.join " " ["cat","dog","cow"])

30+ , test "join slashes" <| assertEqual "home/steve/Desktop" (String.join "/" ["home","steve","Desktop"])

31+ , test "slice 1" <| assertEqual "c" (String.slice 2 3 "abcd")

32+ , test "slice 2" <| assertEqual "abc" (String.slice 0 3 "abcd")

33+ , test "slice 3" <| assertEqual "abc" (String.slice 0 -1 "abcd")

34+ , test "slice 4" <| assertEqual "cd" (String.slice -2 4 "abcd")

3535 ]

3636 in

3737 suite "String" [ simpleTests, combiningTests ]