git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

LICENSE+35−35

compare with golang

unifiedsplit

@@ -41,43 +41,43 @@ PureScript uses the following Haskell library packages. Their license files foll

41base LICENSE file:

41base LICENSE file:

42

42

43 This library (libraries/base) is derived from code from several

43 This library (libraries/base) is derived from code from several

44− sources:

44+ sources:

45−

45+

46 * Code from the GHC project which is largely (c) The University of

46 * Code from the GHC project which is largely (c) The University of

47 Glasgow, and distributable under a BSD-style license (see below),

47 Glasgow, and distributable under a BSD-style license (see below),

48−

48+

49 * Code from the Haskell 98 Report which is (c) Simon Peyton Jones

49 * Code from the Haskell 98 Report which is (c) Simon Peyton Jones

50 and freely redistributable (but see the full license for

50 and freely redistributable (but see the full license for

51 restrictions).

51 restrictions).

52−

52+

53 * Code from the Haskell Foreign Function Interface specification,

53 * Code from the Haskell Foreign Function Interface specification,

54 which is (c) Manuel M. T. Chakravarty and freely redistributable

54 which is (c) Manuel M. T. Chakravarty and freely redistributable

55 (but see the full license for restrictions).

55 (but see the full license for restrictions).

56−

56+

57 The full text of these licenses is reproduced below. All of the

57 The full text of these licenses is reproduced below. All of the

58 licenses are BSD-style or compatible.

58 licenses are BSD-style or compatible.

59−

59+

60 -----------------------------------------------------------------------------

60 -----------------------------------------------------------------------------

61−

61+

62 The Glasgow Haskell Compiler License

62 The Glasgow Haskell Compiler License

63−

63+

64− Copyright 2004, The University Court of the University of Glasgow.

64+ Copyright 2004, The University Court of the University of Glasgow.

65 All rights reserved.

65 All rights reserved.

66−

66+

67 Redistribution and use in source and binary forms, with or without

67 Redistribution and use in source and binary forms, with or without

68 modification, are permitted provided that the following conditions are met:

68 modification, are permitted provided that the following conditions are met:

69−

69+

70 - Redistributions of source code must retain the above copyright notice,

70 - Redistributions of source code must retain the above copyright notice,

71 this list of conditions and the following disclaimer.

71 this list of conditions and the following disclaimer.

72−

72+

73 - Redistributions in binary form must reproduce the above copyright notice,

73 - Redistributions in binary form must reproduce the above copyright notice,

74 this list of conditions and the following disclaimer in the documentation

74 this list of conditions and the following disclaimer in the documentation

75 and/or other materials provided with the distribution.

75 and/or other materials provided with the distribution.

76−

76+

77 - Neither name of the University nor the names of its contributors may be

77 - Neither name of the University nor the names of its contributors may be

78 used to endorse or promote products derived from this software without

78 used to endorse or promote products derived from this software without

79− specific prior written permission.

79+ specific prior written permission.

80−

80+

81 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

81 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

82 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

82 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

83 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

83 INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

@@ -90,14 +90,14 @@ base LICENSE file:

90 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

90 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

91 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

91 OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

92 DAMAGE.

92 DAMAGE.

93−

93+

94 -----------------------------------------------------------------------------

94 -----------------------------------------------------------------------------

95−

95+

96 Code derived from the document "Report on the Programming Language

96 Code derived from the document "Report on the Programming Language

97 Haskell 98", is distributed under the following license:

97 Haskell 98", is distributed under the following license:

98−

98+

99 Copyright (c) 2002 Simon Peyton Jones

99 Copyright (c) 2002 Simon Peyton Jones

100−

100+

101 The authors intend this Report to belong to the entire Haskell

101 The authors intend this Report to belong to the entire Haskell

102 community, and so we grant permission to copy and distribute it for

102 community, and so we grant permission to copy and distribute it for

103 any purpose, provided that it is reproduced in its entirety,

103 any purpose, provided that it is reproduced in its entirety,

@@ -105,15 +105,15 @@ base LICENSE file:

105 copied and distributed for any purpose, provided that the modified

105 copied and distributed for any purpose, provided that the modified

106 version is clearly presented as such, and that it does not claim to

106 version is clearly presented as such, and that it does not claim to

107 be a definition of the Haskell 98 Language.

107 be a definition of the Haskell 98 Language.

108−

108+

109 -----------------------------------------------------------------------------

109 -----------------------------------------------------------------------------

110−

110+

111 Code derived from the document "The Haskell 98 Foreign Function

111 Code derived from the document "The Haskell 98 Foreign Function

112 Interface, An Addendum to the Haskell 98 Report" is distributed under

112 Interface, An Addendum to the Haskell 98 Report" is distributed under

113 the following license:

113 the following license:

114−

114+

115 Copyright (c) 2002 Manuel M. T. Chakravarty

115 Copyright (c) 2002 Manuel M. T. Chakravarty

116−

116+

117 The authors intend this Report to belong to the entire Haskell

117 The authors intend this Report to belong to the entire Haskell

118 community, and so we grant permission to copy and distribute it for

118 community, and so we grant permission to copy and distribute it for

119 any purpose, provided that it is reproduced in its entirety,

119 any purpose, provided that it is reproduced in its entirety,

@@ -121,9 +121,9 @@ base LICENSE file:

121 copied and distributed for any purpose, provided that the modified

121 copied and distributed for any purpose, provided that the modified

122 version is clearly presented as such, and that it does not claim to

122 version is clearly presented as such, and that it does not claim to

123 be a definition of the Haskell 98 Foreign Function Interface.

123 be a definition of the Haskell 98 Foreign Function Interface.

124−

124+

125 -----------------------------------------------------------------------------

125 -----------------------------------------------------------------------------

126−

126+

127containers LICENSE file:

127containers LICENSE file:

128

128

129 The Glasgow Haskell Compiler License

129 The Glasgow Haskell Compiler License

@@ -161,7 +161,7 @@ containers LICENSE file:

161directory LICENSE file:

161directory LICENSE file:

162

162

163 This library (libraries/base) is derived from code from two

163 This library (libraries/base) is derived from code from two

164− sources:

164+ sources:

165

165

166 * Code from the GHC project which is largely (c) The University of

166 * Code from the GHC project which is largely (c) The University of

167 Glasgow, and distributable under a BSD-style license (see below),

167 Glasgow, and distributable under a BSD-style license (see below),

@@ -177,7 +177,7 @@ directory LICENSE file:

177

177

178 The Glasgow Haskell Compiler License

178 The Glasgow Haskell Compiler License

179

179

180− Copyright 2004, The University Court of the University of Glasgow.

180+ Copyright 2004, The University Court of the University of Glasgow.

181 All rights reserved.

181 All rights reserved.

182

182

183 Redistribution and use in source and binary forms, with or without

183 Redistribution and use in source and binary forms, with or without

@@ -185,14 +185,14 @@ directory LICENSE file:

185

185

186 - Redistributions of source code must retain the above copyright notice,

186 - Redistributions of source code must retain the above copyright notice,

187 this list of conditions and the following disclaimer.

187 this list of conditions and the following disclaimer.

188−

188+

189 - Redistributions in binary form must reproduce the above copyright notice,

189 - Redistributions in binary form must reproduce the above copyright notice,

190 this list of conditions and the following disclaimer in the documentation

190 this list of conditions and the following disclaimer in the documentation

191 and/or other materials provided with the distribution.

191 and/or other materials provided with the distribution.

192−

192+

193 - Neither name of the University nor the names of its contributors may be

193 - Neither name of the University nor the names of its contributors may be

194 used to endorse or promote products derived from this software without

194 used to endorse or promote products derived from this software without

195− specific prior written permission.

195+ specific prior written permission.

196

196

197 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

197 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

198 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

198 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

@@ -451,7 +451,7 @@ pattern-arrows LICENSE file:

451process LICENSE file:

451process LICENSE file:

452

452

453 This library (libraries/process) is derived from code from two

453 This library (libraries/process) is derived from code from two

454− sources:

454+ sources:

455

455

456 * Code from the GHC project which is largely (c) The University of

456 * Code from the GHC project which is largely (c) The University of

457 Glasgow, and distributable under a BSD-style license (see below),

457 Glasgow, and distributable under a BSD-style license (see below),

@@ -467,7 +467,7 @@ process LICENSE file:

467

467

468 The Glasgow Haskell Compiler License

468 The Glasgow Haskell Compiler License

469

469

470− Copyright 2004, The University Court of the University of Glasgow.

470+ Copyright 2004, The University Court of the University of Glasgow.

471 All rights reserved.

471 All rights reserved.

472

472

473 Redistribution and use in source and binary forms, with or without

473 Redistribution and use in source and binary forms, with or without

@@ -475,14 +475,14 @@ process LICENSE file:

475

475

476 - Redistributions of source code must retain the above copyright notice,

476 - Redistributions of source code must retain the above copyright notice,

477 this list of conditions and the following disclaimer.

477 this list of conditions and the following disclaimer.

478−

478+

479 - Redistributions in binary form must reproduce the above copyright notice,

479 - Redistributions in binary form must reproduce the above copyright notice,

480 this list of conditions and the following disclaimer in the documentation

480 this list of conditions and the following disclaimer in the documentation

481 and/or other materials provided with the distribution.

481 and/or other materials provided with the distribution.

482−

482+

483 - Neither name of the University nor the names of its contributors may be

483 - Neither name of the University nor the names of its contributors may be

484 used to endorse or promote products derived from this software without

484 used to endorse or promote products derived from this software without

485− specific prior written permission.

485+ specific prior written permission.

486

486

487 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

487 THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

488 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

488 GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

RELEASE-0.2.md+13−13

@@ -10,31 +10,31 @@ Many thanks to the [contributors](https://github.com/purescript/purescript/graph

10- RankNTypes

10- RankNTypes

11

11

12 This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:

12 This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:

13−

13+

14 rank2 :: (forall a. a -> a) -> Number

14 rank2 :: (forall a. a -> a) -> Number

15 rank2 = \f -> if f true then f 1 else f 2

15 rank2 = \f -> if f true then f 1 else f 2

16−

16+

17- Modules

17- Modules

18- Polymorphic Object Update

18- Polymorphic Object Update

19

19

20 Records now support member update in which the type of the field changes during the update. For example:

20 Records now support member update in which the type of the field changes during the update. For example:

21

21

22 data Wrap a = Wrap a

22 data Wrap a = Wrap a

23−

23+

24 update = \o -> o { prop = Wrap o.prop }

24 update = \o -> o { prop = Wrap o.prop }

25

25

26### Enhancements

26### Enhancements

27

27

28- Naked expressions as statements

28- Naked expressions as statements

29−

29+

30 Naked expressions of type `{}` can now be used as statements.

30 Naked expressions of type `{}` can now be used as statements.

31

31

32- Split code generation into `AST -> JS` and `JS -> String`

32- Split code generation into `AST -> JS` and `JS -> String`

33−

33+

34 JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.

34 JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.

35−

35+

36- Syntactic sugar for introducing curried functions

36- Syntactic sugar for introducing curried functions

37−

37+

38 Single-argument functions and multiple-argument functions can now be introduced in the same way:

38 Single-argument functions and multiple-argument functions can now be introduced in the same way:

39

39

40 test = \a (b, c) d -> a + b + c + d

40 test = \a (b, c) d -> a + b + c + d

@@ -42,32 +42,32 @@ Many thanks to the [contributors](https://github.com/purescript/purescript/graph

42- JavaScript optimizations

42- JavaScript optimizations

43

43

44 Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.

44 Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.

45−

45+

46- Generate formatted Javascript

46- Generate formatted Javascript

47

47

48 The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.

48 The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.

49

49

50- More valid infix operators

50- More valid infix operators

51−

51+

52 The colon and period characters are now valid in infix operator names.

52 The colon and period characters are now valid in infix operator names.

53

53

54### Syntax Changes

54### Syntax Changes

55

55

56- Avoid 'do' keyword for blocks

56- Avoid 'do' keyword for blocks

57−

57+

58 `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.

58 `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.

59

59

60- Member foreign import syntax

60- Member foreign import syntax

61

61

62− A small syntactic addition to the FFI, to support a common use case.

62+ A small syntactic addition to the FFI, to support a common use case.

63

63

64- Make FFI syntax match Haskell

64- Make FFI syntax match Haskell

65−

65+

66 Use `foreign import` instead of `extern`.

66 Use `foreign import` instead of `extern`.

67

67

68- Make record declaration syntax match Haskell

68- Make record declaration syntax match Haskell

69- Simplify array binders

69- Simplify array binders

70−

70+

71 There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.

71 There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.

72

72

73- Array indexing syntax is ambiguous

73- Array indexing syntax is ambiguous

RELEASE-0.3.md+8−8

@@ -14,40 +14,40 @@ Many thanks to the [contributors](https://github.com/purescript/purescript/graph

14 sum (x:xs) = x + sum xs

14 sum (x:xs) = x + sum xs

15

15

16- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:

16- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:

17−

17+

18 class Truthy a where

18 class Truthy a where

19 isTrue :: a -> Boolean

19 isTrue :: a -> Boolean

20−

20+

21 instance Truthy Boolean where

21 instance Truthy Boolean where

22 isTrue b = b

22 isTrue b = b

23−

23+

24 instance Truthy String where

24 instance Truthy String where

25 isTrue "" = false

25 isTrue "" = false

26 isTrue _ = true

26 isTrue _ = true

27−

27+

28 ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b

28 ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b

29 ifThenElse a tr fa = if isTrue a then tr else fa

29 ifThenElse a tr fa = if isTrue a then tr else fa

30

30

31- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:

31- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:

32

32

33 data Maybe = Nothing | Just a

33 data Maybe = Nothing | Just a

34−

34+

35 instance Prelude.Monad Maybe where

35 instance Prelude.Monad Maybe where

36 ret = Just

36 ret = Just

37 (>>=) Nothing _ = Nothing

37 (>>=) Nothing _ = Nothing

38 (>>=) (Just a) f = f a

38 (>>=) (Just a) f = f a

39−

39+

40 test = do

40 test = do

41 x <- Just 1

41 x <- Just 1

42 y <- Just 2

42 y <- Just 2

43 ret $ x + y

43 ret $ x + y

44−

44+

45- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:

45- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:

46

46

47 test = do

47 test = do

48 trace "Testing"

48 trace "Testing"

49 throwError "Error!"

49 throwError "Error!"

50−

50+

51 has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.

51 has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.

52 See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.

52 See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.

53 Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).

53 Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).

RELEASE-0.4.md+8−8

@@ -8,17 +8,17 @@ This release saw major contributions from [a number of new contributors](https:/

8- Try out the latest features [here](http://tryps.functorial.com).

8- Try out the latest features [here](http://tryps.functorial.com).

9

9

10## Breaking Changes

10## Breaking Changes

11−

11+

12- Multiple argument functions are no longer available.

12- Multiple argument functions are no longer available.

13- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.

13- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.

14- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.

14- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.

15−

15+

16### New Features

16### New Features

17−

17+

18- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.

18- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.

19−

19+

20### Enhancements

20### Enhancements

21−

21+

22- The `->` and `[]` types are now usable in type class instances.

22- The `->` and `[]` types are now usable in type class instances.

23- The file path is included in syntax error messages.

23- The file path is included in syntax error messages.

24- Most reserved Javascript names (`return`, `const`, etc) are now usable.

24- Most reserved Javascript names (`return`, `const`, etc) are now usable.

@@ -28,9 +28,9 @@ This release saw major contributions from [a number of new contributors](https:/

28- It is no longer necessary to sort modules in order of dependencies manually.

28- It is no longer necessary to sort modules in order of dependencies manually.

29- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.

29- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.

30- New optimizer rules were added to inline JavaScript's built-in operators.

30- New optimizer rules were added to inline JavaScript's built-in operators.

31−

31+

32### Bug Fixes

32### Bug Fixes

33−

33+

34- Floats parse correctly.

34- Floats parse correctly.

35- Using data constructors in pattern matches now works properly across modules.

35- Using data constructors in pattern matches now works properly across modules.

36- PureScript modules no longer overwrite global objects with the same name.

36- PureScript modules no longer overwrite global objects with the same name.

@@ -43,7 +43,7 @@ This release saw major contributions from [a number of new contributors](https:/

43- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).

43- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).

44- Modules containing mutually recursive type synonyms and data declarations now compile correctly.

44- Modules containing mutually recursive type synonyms and data declarations now compile correctly.

45- A number of bugs in the optimizer were addressed.

45- A number of bugs in the optimizer were addressed.

46−

46+

47### Libraries

47### Libraries

48

48

49- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.

49- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.

RELEASE-0.5.md+3−3

@@ -54,7 +54,7 @@

54- The escape check was removed, since it was too restrictive (paf31)

54- The escape check was removed, since it was too restrictive (paf31)

55- The binary operator reordering step was greatly simplified (paf31)

55- The binary operator reordering step was greatly simplified (paf31)

56- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)

56- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)

57−- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)

57+- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)

58- Unary minus and signed numeric literals are now supported again (paf31, garyb)

58- Unary minus and signed numeric literals are now supported again (paf31, garyb)

59- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)

59- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)

60- Error messages now display source positions (paf31, garyb)

60- Error messages now display source positions (paf31, garyb)

@@ -63,7 +63,7 @@

63- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31)

63- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31)

64- Error messages for classes with undefined or missing members have been improved (garyb)

64- Error messages for classes with undefined or missing members have been improved (garyb)

65- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31)

65- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31)

66−

66+

67### Bug Fixes

67### Bug Fixes

68

68

69- The subsumes relation has been fixed for object types (paf31)

69- The subsumes relation has been fixed for object types (paf31)

@@ -94,6 +94,6 @@

94- The `grunt-purescript` plugin has been updated to provide support for new command line options.

94- The `grunt-purescript` plugin has been updated to provide support for new command line options.

95- There is a new `gulp-purescript` plugin available for compiling with Gulp.

95- There is a new `gulp-purescript` plugin available for compiling with Gulp.

96

96

97−### Documentation

97+### Documentation

98

98

99- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf)

99- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf)

RELEASE-0.7.md+6−6

@@ -12,7 +12,7 @@ positive _ = false

12but this is not:

12but this is not:

13

13

14```haskell

14```haskell

15−positive n | n > 0

15+positive n | n > 0

16 = true

16 = true

17positive _ = false

17positive _ = false

18```

18```

@@ -32,20 +32,20 @@ positive _ = false

32

32

33### Breaking Changes

33### Breaking Changes

34

34

35−-

35+-

36

36

37### New Features

37### New Features

38

38

39−-

39+-

40

40

41### Enhancements

41### Enhancements

42

42

43−-

43+-

44

44

45### Libraries

45### Libraries

46

46

47−-

47+-

48

48

49### Documentation

49### Documentation

50

50

51−-

51+-

bundle/README+4−4

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

1− ____ ____ _ _

1+ ____ ____ _ _

2−| _ \ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_

2+| _ \ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_

3| |_) | | | | '__/ _ \___ \ / __| '__| | '_ \| __|

3| |_) | | | | '__/ _ \___ \ / __| '__| | '_ \| __|

4−| __/| |_| | | | __/___) | (__| | | | |_) | |_

4+| __/| |_| | | | __/___) | (__| | | | |_) | |_

5|_| \__,_|_| \___|____/ \___|_| |_| .__/ \__|

5|_| \__,_|_| \___|____/ \___|_| |_| .__/ \__|

6− |_|

6+ |_|

7

7

8Installation Instructions

8Installation Instructions

9-------------------------

9-------------------------

bundle/build.sh+1−1

@@ -4,7 +4,7 @@ SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )

4

4

5OS=$1

5OS=$1

6

6

7−if [ -z $OS ]

7+if [ -z $OS ]

8then

8then

9 echo "Usage: build.sh osname"

9 echo "Usage: build.sh osname"

10 exit 1

10 exit 1

bundle/winbuild.sh+3−3

@@ -26,9 +26,9 @@ cp README build/purescript/

26cp ../LICENSE build/purescript/

26cp ../LICENSE build/purescript/

27

27

28# Make the binary bundle

28# Make the binary bundle

29−pushd build

29+pushd build

30tar -zcvf ../win64.tar.gz purescript

30tar -zcvf ../win64.tar.gz purescript

31−popd

31+popd

32

32

33# Calculate the MD5 hash

33# Calculate the MD5 hash

34md5sum win64.tar.gz > win64.md5

34md5sum win64.tar.gz > win64.md5

@@ -36,5 +36,5 @@ md5sum win64.tar.gz > win64.md5

36# Remove the staging directory

36# Remove the staging directory

37rm -rf build/

37rm -rf build/

38

38

39−popd

39+popd

40

40

examples/failing/DuplicateDeclarationsInLet.pursnew file+9

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

1+module Main where

2+

3+foo = a

4+ where

5+ a :: Number

6+ a = 1

7+

8+ a :: Number

9+ a = 2

examples/failing/NewtypeMultiArgs.purs+1−1

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

1module Main where

1module Main where

2

2

3−newtype Thing = Thing String Boolean

3+newtype Thing = Thing String Boolean

examples/failing/NewtypeMultiCtor.purs+1−1

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

1module Main where

1module Main where

2

2

3−newtype Thing = Thing String | Other

3+newtype Thing = Thing String | Other

examples/failing/SkolemEscape2.purs+1−1

@@ -6,4 +6,4 @@ import Control.Monad.ST

6

6

7test _ = do

7test _ = do

8 r <- runST (newSTRef 0)

8 r <- runST (newSTRef 0)

9− return 0

9+ return 0

examples/failing/UnknownType.purs+1−1

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

1module Main where

1module Main where

2

2

3test :: Number -> Something

3test :: Number -> Something

4−test = {}

4+test = {}

examples/manual/failing/ArgLengthMismatch.purs+1−1

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

1module ArgLengthMismatch where

1module ArgLengthMismatch where

2

2

3 f x y = true

3 f x y = true

4− f = false

4+ f = false

examples/manual/failing/ExportExplicit.purs+1−1

@@ -2,4 +2,4 @@

2module M1 (x, y, z) where

2module M1 (x, y, z) where

3

3

4 x = 1

4 x = 1

5− y = 2

5+ y = 2

examples/manual/failing/ExportExplicit1.purs+2−2

@@ -5,9 +5,9 @@ module M1 (X(X)) where

5module Main where

5module Main where

6

6

7 import M1

7 import M1

8−

8+

9 testX = X

9 testX = X

10−

10+

11 -- should fail as Y constructor is not exported from M1

11 -- should fail as Y constructor is not exported from M1

12 testY = Y

12 testY = Y

13

13

examples/manual/failing/ExportExplicit2.purs+1−1

@@ -2,4 +2,4 @@

2module M1 (X(Y)) where

2module M1 (X(Y)) where

3

3

4 data X = X

4 data X = X

5− data Y = Y

5+ data Y = Y

examples/manual/failing/ExportExplicit3.purs+1−1

@@ -6,7 +6,7 @@ module M1 (X(..)) where

6module Main where

6module Main where

7

7

8 import M1

8 import M1

9−

9+

10 -- should fail as Z is not exported from M1

10 -- should fail as Z is not exported from M1

11 testZ = M1.Z

11 testZ = M1.Z

12

12

examples/manual/failing/RedefinedFixity.purs+1−1

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

1module RedefinedFixity where

1module RedefinedFixity where

2

2

3 (!?) x y = x + y

3 (!?) x y = x + y

4−

4+

5 infix 2 !?

5 infix 2 !?

6 infix 2 !?

6 infix 2 !?

examples/manual/failing/RequiredHiddenType.purs+2−2

@@ -3,6 +3,6 @@ module Foo (B(..), a, b) where

3

3

4 data A = A

4 data A = A

5 data B = B

5 data B = B

6−

6+

7 a = A

7 a = A

8− b = B

8+ b = B

examples/manual/passing/ExportExplicit.purs+2−2

@@ -3,7 +3,7 @@ module M1 (X(X), Z(..), foo) where

3 data X = X | Y

3 data X = X | Y

4 data Z = Z

4 data Z = Z

5

5

6− foo :: Number

6+ foo :: Number

7 foo = 0

7 foo = 0

8

8

9 bar :: Number

9 bar :: Number

@@ -12,7 +12,7 @@ module M1 (X(X), Z(..), foo) where

12module Main where

12module Main where

13

13

14 import M1

14 import M1

15−

15+

16 testX = X

16 testX = X

17 testZ = Z

17 testZ = Z

18 testFoo = foo

18 testFoo = foo

examples/manual/passing/ExportExplicit2.purs+1−1

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

1module M1 (bar) where

1module M1 (bar) where

2

2

3− foo :: Number

3+ foo :: Number

4 foo = 0

4 foo = 0

5

5

6 bar :: Number

6 bar :: Number

examples/manual/passing/Import.purs+1−1

@@ -13,7 +13,7 @@ module M2 where

13 import M1

13 import M1

14

14

15 main = \_ -> foo 42

15 main = \_ -> foo 42

16−

16+

17module Main where

17module Main where

18

18

19main = Debug.Trace.trace "Done"

19main = Debug.Trace.trace "Done"

examples/manual/passing/ImportExplicit.purs+1−1

@@ -7,7 +7,7 @@ module Main where

7

7

8 import M1 (X(..))

8 import M1 (X(..))

9

9

10− testX :: X

10+ testX :: X

11 testX = X

11 testX = X

12 testY = Y

12 testY = Y

13

13

examples/manual/passing/ImportQualified.purs+3−3

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

1module M1 where

1module M1 where

2−

2+

3 trace x = x

3 trace x = x

4

4

5module Main where

5module Main where

@@ -8,5 +8,5 @@ module Main where

8 import Control.Monad.Eff

8 import Control.Monad.Eff

9 import M1

9 import M1

10 import qualified Debug.Trace as T

10 import qualified Debug.Trace as T

11−

11+

12− main = T.trace (trace "Done")

12+ main = T.trace (trace "Done")

examples/manual/passing/Module.purs+1−1

@@ -22,7 +22,7 @@ module M2 where

22

22

23 match :: M1.Foo -> String

23 match :: M1.Foo -> String

24 match = \f -> case f of M1.Foo s -> s ++ "foo"

24 match = \f -> case f of M1.Foo s -> s ++ "foo"

25−

25+

26module Main where

26module Main where

27

27

28main = Debug.Trace.trace "Done"

28main = Debug.Trace.trace "Done"

examples/manual/passing/ModuleDeps.purs+1−1

@@ -11,7 +11,7 @@ bar = M3.baz

11module M3 where

11module M3 where

12

12

13baz = 1

13baz = 1

14−

14+

15module Main where

15module Main where

16

16

17main = Debug.Trace.trace "Done"

17main = Debug.Trace.trace "Done"

examples/passing/810.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

2+

3+data Maybe a = Nothing | Just a

4+

5+test :: forall a. Maybe a -> Maybe a

6+test m = o.x

7+ where

8+ o = case m of Nothing -> { x : Nothing }

9+ Just a -> { x : Just a }

10+

11+main = Debug.Trace.trace "Done"

examples/passing/BindersInFunctions.purs+7−5

@@ -5,12 +5,14 @@ import Prelude

5tail = \(_:xs) -> xs

5tail = \(_:xs) -> xs

6

6

7foreign import error

7foreign import error

8+ """

8− "function error(msg) {\

9+ function error(msg) {

9− \ throw msg;\

10+ throw msg;

11+ }

10− \}" :: forall a. String -> a

12+ """ :: forall a. String -> a

11

13

12−main =

14+main =

13 let ts = tail [1, 2, 3] in

15 let ts = tail [1, 2, 3] in

14− if ts == [2, 3]

16+ if ts == [2, 3]

15 then Debug.Trace.trace "Done"

17 then Debug.Trace.trace "Done"

16 else error "Incorrect result from 'tails'."

18 else error "Incorrect result from 'tails'."

examples/passing/BindingGroups.purs+2−2

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

1module Main where

1module Main where

2−

2+

3−foo = bar

3+foo = bar

4 where bar r = r + 1

4 where bar r = r + 1

5

5

6r = foo 2

6r = foo 2

examples/passing/CheckSynonymBug.purs+6−4

@@ -2,12 +2,14 @@ module Main where

2

2

3 import Prelude

3 import Prelude

4

4

5− type Foo a = [a]

5+ type Foo a = [a]

6

6

7 foreign import length

7 foreign import length

8+ """

8− "function length(a) {\

9+ function length(a) {

9− \ return a.length;\

10+ return a.length;

11+ }

10− \}" :: forall a. [a] -> Number

12+ """ :: forall a. [a] -> Number

11

13

12 foo _ = length ([] :: Foo Number)

14 foo _ = length ([] :: Foo Number)

13

15

examples/passing/Comparisons.purs+8−6

@@ -6,12 +6,14 @@ import Debug.Trace

6foreign import data Assert :: !

6foreign import data Assert :: !

7

7

8foreign import assert

8foreign import assert

9+ """

9− "function assert(x) {\

10+ function assert(x) {

10− \ return function () {\

11+ return function() {

11− \ if (!x) throw new Error('assertion failed');\

12+ if (!x) throw new Error('assertion failed');

12− \ return {};\

13+ return {};

13− \ };\

14+ };

15+ }

14− \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit

16+ """ :: forall e. Boolean -> Eff (assert :: Assert | e) Unit

15

17

16main = do

18main = do

17 assert (1 < 2)

19 assert (1 < 2)

examples/passing/Conditional.purs+1−1

@@ -2,7 +2,7 @@ module Main where

2

2

3 import Prelude ()

3 import Prelude ()

4

4

5− fns = \f -> if f true then f else \x -> x

5+ fns = \f -> if f true then f else \x -> x

6

6

7 not = \x -> if x then false else true

7 not = \x -> if x then false else true

8

8

examples/passing/Console.purs+1−1

@@ -9,5 +9,5 @@ replicateM_ 0 _ = return {}

9replicateM_ n act = do

9replicateM_ n act = do

10 act

10 act

11 replicateM_ (n - 1) act

11 replicateM_ (n - 1) act

12−

12+

13main = replicateM_ 10 (trace "Hello World!")

13main = replicateM_ 10 (trace "Hello World!")

examples/passing/DeepArrayBinder.purs+6−4

@@ -6,10 +6,12 @@ match2 :: [Number] -> Number

6match2 (x : y : xs) = x * y + match2 xs

6match2 (x : y : xs) = x * y + match2 xs

7match2 _ = 0

7match2 _ = 0

8

8

9−foreign import explode

9+foreign import explode

10+ """

10− "function explode() {\

11+ function explode() {

11− \ throw new Error('Incorrect result');\

12+ throw new Error('Incorrect result');

13+ }

12− \}" :: forall eff a. Eff eff a

14+ """ :: forall eff a. Eff eff a

13

15

14main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of

16main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of

15 100 -> Debug.Trace.trace "Done"

17 100 -> Debug.Trace.trace "Done"

examples/passing/DeepCase.purs+2−2

@@ -4,9 +4,9 @@ import Debug.Trace

4import Control.Monad.Eff

4import Control.Monad.Eff

5import Control.Monad.ST

5import Control.Monad.ST

6

6

7−f x y =

7+f x y =

8 let

8 let

9− g = case y of

9+ g = case y of

10 0 -> x

10 0 -> x

11 x -> 1 + x * x

11 x -> 1 + x * x

12 in g + x + y

12 in g + x + y

examples/passing/Dollar.purs+1−1

@@ -12,5 +12,5 @@ id x = x

12test1 x = id $ id $ id $ id $ x

12test1 x = id $ id $ id $ id $ x

13

13

14test2 x = id id $ id x

14test2 x = id id $ id x

15−

15+

16main = Debug.Trace.trace "Done"

16main = Debug.Trace.trace "Done"

examples/passing/EmptyDataDecls.purs+12−8

@@ -11,19 +11,23 @@ nil :: forall a. ArrayBox Z a

11nil = ArrayBox []

11nil = ArrayBox []

12

12

13foreign import concat

13foreign import concat

14+ """

14− "function concat(l1) {\

15+ function concat(l1) {

15− \ return function (l2) {\

16+ return function(l2) {

16− \ return l1.concat(l2);\

17+ return l1.concat(l2);

17− \ };\

18+ };

19+ }

18− \}" :: forall a. [a] -> [a] -> [a]

20+ """ :: forall a. [a] -> [a] -> [a]

19

21

20cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a

22cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a

21cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs

23cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs

22

24

23foreign import error

25foreign import error

26+ """

24− "function error(msg) {\

27+ function error(msg) {

25− \ throw msg;\

28+ throw msg;

29+ }

26− \}" :: forall a. String -> a

30+ """ :: forall a. String -> a

27

31

28main = case cons' 1 $ cons' 2 $ cons' 3 nil of

32main = case cons' 1 $ cons' 2 $ cons' 3 nil of

29 ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"

33 ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"

examples/passing/EmptyRow.purs+1−1

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

1module Main where

1module Main where

2

2

3−data Foo r = Foo { | r }

3+data Foo r = Foo { | r }

4

4

5test :: Foo ()

5test :: Foo ()

6test = Foo {}

6test = Foo {}

examples/passing/ExtendedInfixOperators.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

2+

3+zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]

4+zipWith _ [] _ = []

5+zipWith _ _ [] = []

6+zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys

7+

8+test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]

9+

10+comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering

11+comparing f = compare `Data.Function.on` f

12+

13+sum [] = 0

14+sum (x:xs) = x + sum xs

15+

16+test2 = [1, 2, 3] `comparing sum` [4, 5, 6]

17+

18+main = do

19+ Debug.Trace.print test1

20+ Debug.Trace.print test2

examples/passing/ExternRaw.purs+20−7

@@ -1,13 +1,26 @@

1module Main where

1module Main where

2

2

3−foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a

3+foreign import first

4+ """

5+ function first(xs) {

6+ return xs[0];

7+ }

8+ """ :: forall a. [a] -> a

4

9

5−foreign import loop "function loop() { while (true) {} }" :: forall a. a

10+foreign import loop

11+ """

12+ function loop() {

13+ while (true) {}

14+ }

15+ """ :: forall a. a

6

16

7−foreign import concat "function concat(xs) { \

17+foreign import concat

18+ """

19+ function concat(xs) {

8− \ return function(ys) { \

20+ return function(ys) {

9− \ return xs.concat(ys); \

21+ return xs.concat(ys);

10− \ };\

22+ };

23+ }

11− \}" :: forall a. [a] -> [a] -> [a]

24+ """ :: forall a. [a] -> [a] -> [a]

12

25

13main = Debug.Trace.trace "Done"

26main = Debug.Trace.trace "Done"

examples/passing/FFI.purs+6−4

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

1module Main where

1module Main where

2

2

3−foreign import foo

3+foreign import foo

4+ """

4− "function foo(s) {\

5+ function foo(s) {

5− \ return s;\

6+ return s;

7+ }

6− \}" :: String -> String

8+ """ :: String -> String

7

9

8bar :: String -> String

10bar :: String -> String

9bar _ = foo "test"

11bar _ = foo "test"

examples/passing/FinalTagless.purs+1−1

@@ -5,7 +5,7 @@ import Prelude

5class E e where

5class E e where

6 num :: Number -> e Number

6 num :: Number -> e Number

7 add :: e Number -> e Number -> e Number

7 add :: e Number -> e Number -> e Number

8−

8+

9type Expr a = forall e. (E e) => e a

9type Expr a = forall e. (E e) => e a

10

10

11data Id a = Id a

11data Id a = Id a

examples/passing/FunctionScope.purs+6−4

@@ -5,10 +5,12 @@ module Main where

5 mkValue :: Number -> Number

5 mkValue :: Number -> Number

6 mkValue id = id

6 mkValue id = id

7

7

8− foreign import error

8+ foreign import error

9+ """

9− "function error(msg) {\

10+ function error(msg) {

10− \ throw msg;\

11+ throw msg;

12+ }

11− \}" :: forall a. String -> a

13+ """ :: forall a. String -> a

12

14

13 main = do

15 main = do

14 let value = mkValue 1

16 let value = mkValue 1

examples/passing/Functions2.purs+5−3

@@ -6,9 +6,11 @@ module Main where

6 test = \const _ -> const

6 test = \const _ -> const

7

7

8 foreign import error

8 foreign import error

9+ """

9− "function error(msg) {\

10+ function error(msg) {

10− \ throw msg;\

11+ throw msg;

12+ }

11− \}" :: forall a. String -> a

13+ """ :: forall a. String -> a

12

14

13 main = do

15 main = do

14 let value = test "Done" {}

16 let value = test "Done" {}

examples/passing/Guards.purs+2−2

@@ -21,9 +21,9 @@ module Main where

21 | otherwise -> m

21 | otherwise -> m

22

22

23 testIndentation :: Number -> Number -> Number

23 testIndentation :: Number -> Number -> Number

24− testIndentation x y | x > 0

24+ testIndentation x y | x > 0

25 = x + y

25 = x + y

26− | otherwise

26+ | otherwise

27 = y - x

27 = y - x

28

28

29 main = Debug.Trace.trace $ min "Done" "ZZZZ"

29 main = Debug.Trace.trace $ min "Done" "ZZZZ"

examples/passing/HoistError.purs+7−5

@@ -4,11 +4,13 @@ import Control.Monad.Eff

4import Debug.Trace

4import Debug.Trace

5

5

6foreign import f

6foreign import f

7+ """

7− "function f(x) {\

8+ function f(x) {

8− \ return function () {\

9+ return function() {

9− \ if (x !== 0) throw new Error('x is not 0');\

10+ if (x !== 0) throw new Error('x is not 0');

11+ };

10− \ }\

12+ }

11− \}" :: forall e. Number -> Eff e Number

13+ """ :: forall e. Number -> Eff e Number

12

14

13main = do

15main = do

14 let x = 0

16 let x = 0

examples/passing/JSReserved.purs+2−2

@@ -4,9 +4,9 @@ module Main where

4

4

5 yield = 0

5 yield = 0

6 member = 1

6 member = 1

7−

7+

8 public = \return -> return

8 public = \return -> return

9−

9+

10 this catch = catch

10 this catch = catch

11

11

12 main = Debug.Trace.trace "Done"

12 main = Debug.Trace.trace "Done"

examples/passing/KindedType.purs+1−1

@@ -26,6 +26,6 @@ class Clazz (a :: *) where

26 def :: a

26 def :: a

27

27

28instance clazzString :: Clazz String where

28instance clazzString :: Clazz String where

29− def = "test"

29+ def = "test"

30

30

31main = Debug.Trace.trace "Done"

31main = Debug.Trace.trace "Done"

examples/passing/Let.purs+7−7

@@ -4,12 +4,12 @@ import Prelude

4import Control.Monad.Eff

4import Control.Monad.Eff

5import Control.Monad.ST

5import Control.Monad.ST

6

6

7−test1 x = let

7+test1 x = let

8 y :: Number

8 y :: Number

9− y = x + 1

9+ y = x + 1

10 in y

10 in y

11

11

12−test2 x y =

12+test2 x y =

13 let x' = x + 1 in

13 let x' = x + 1 in

14 let y' = y + 1 in

14 let y' = y + 1 in

15 x' + y'

15 x' + y'

@@ -17,10 +17,10 @@ test2 x y =

17test3 = let f x y z = x + y + z in

17test3 = let f x y z = x + y + z in

18 f 1 2 3

18 f 1 2 3

19

19

20−test4 = let f x [y, z] = x y z in

20+test4 = let f x [y, z] = x y z in

21 f (+) [1, 2]

21 f (+) [1, 2]

22

22

23−test5 = let

23+test5 = let

24 f x | x > 0 = g (x / 2) + 1

24 f x | x > 0 = g (x / 2) + 1

25 f x = 0

25 f x = 0

26 g x = f (x - 1) + 1

26 g x = f (x - 1) + 1

@@ -42,12 +42,12 @@ test7 = let

42 in if f true then f 1 else f 2

42 in if f true then f 1 else f 2

43

43

44test8 :: Number -> Number

44test8 :: Number -> Number

45−test8 x = let

45+test8 x = let

46 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

46 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

47 go y = go $ (y + x / y) / 2

47 go y = go $ (y + x / y) / 2

48 in go x

48 in go x

49

49

50−test10 _ =

50+test10 _ =

51 let

51 let

52 f x = g x * 3

52 f x = g x * 3

53 g x = f x / 2

53 g x = f x / 2

examples/passing/Monad.purs+2−2

@@ -17,12 +17,12 @@ module Main where

17 maybe = { return : Just

17 maybe = { return : Just

18 , bind : \ma f -> case ma of

18 , bind : \ma f -> case ma of

19 Nothing -> Nothing

19 Nothing -> Nothing

20− Just a -> f a

20+ Just a -> f a

21 }

21 }

22

22

23 test :: forall m. Monad m -> m Number

23 test :: forall m. Monad m -> m Number

24 test = \m -> m.bind (m.return 1) (\n1 ->

24 test = \m -> m.bind (m.return 1) (\n1 ->

25− m.bind (m.return "Test") (\n2 ->

25+ m.bind (m.return "Test") (\n2 ->

26 m.return n1))

26 m.return n1))

27

27

28 test1 = test id

28 test1 = test id

examples/passing/MutRec.purs+1−1

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

1−module Main where

1+module Main where

2

2

3 import Prelude

3 import Prelude

4

4

examples/passing/MutRec2.purs+1−1

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

1module Main where

1module Main where

2

2

3data A = A B

3data A = A B

4−

4+

5data B = B A

5data B = B A

6

6

7foreign import data S :: *

7foreign import data S :: *

examples/passing/MutRec3.purs+1−1

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

1module Main where

1module Main where

2

2

3data A = A B

3data A = A B

4−

4+

5data B = B A

5data B = B A

6

6

7foreign import data S :: *

7foreign import data S :: *

examples/passing/NamedPatterns.purs+1−1

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

1module Main where

1module Main where

2

2

3− foo = \x -> case x of

3+ foo = \x -> case x of

4 y@{ foo = "Foo" } -> y

4 y@{ foo = "Foo" } -> y

5 y -> y

5 y -> y

6

6

examples/passing/Newtype.purs+3−3

@@ -12,11 +12,11 @@ newtype Box a = Box a

12

12

13instance showBox :: (Show a) => Show (Box a) where

13instance showBox :: (Show a) => Show (Box a) where

14 show (Box x) = "Box " ++ show x

14 show (Box x) = "Box " ++ show x

15−

15+

16apply f x = f x

16apply f x = f x

17−

17+

18main = do

18main = do

19 print $ Thing "hello"

19 print $ Thing "hello"

20 print $ Box 42

20 print $ Box 42

21 print $ apply Box 9000

21 print $ apply Box 9000

22− trace "Done"

22+ trace "Done"

examples/passing/NewtypeWithRecordUpdate.pursnew file+15

@@ -0,0 +1,15 @@

1+-- https://github.com/purescript/purescript/issues/812

2+

3+module Main where

4+

5+import Debug.Trace

6+

7+newtype NewType a = NewType (Object a)

8+

9+rec1 :: Object (a :: Number, b :: Number, c:: Number)

10+rec1 = { a: 0, b: 0, c: 0 }

11+

12+rec2 :: NewType (a :: Number, b :: Number, c :: Number)

13+rec2 = NewType (rec1 { a = 1 })

14+

15+main = trace "Done"

examples/passing/ObjectGetter.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

2+

3+getX = _.x

4+

5+point = { x: 1, y: 0 }

6+

7+main = do

8+ Debug.Trace.print $ getX point

9+ Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" }

10+ Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } }

11+ Debug.Trace.trace $ _.value { value: "Done!" }

examples/passing/ObjectSynonym.purs+1−1

@@ -10,4 +10,4 @@ type Outer = { inner :: Inner }

10outer :: Outer

10outer :: Outer

11outer = { inner: inner }

11outer = { inner: inner }

12

12

13−main = Debug.Trace.trace "Done"

13+main = Debug.Trace.trace "Done"

examples/passing/ObjectUpdate2.purs+1−1

@@ -7,7 +7,7 @@ foreign import x "var x = {};" :: forall r. X r

7blah :: forall r. X r -> X r

7blah :: forall r. X r -> X r

8blah x = x

8blah x = x

9

9

10−test = blah x

10+test = blah x

11 { baz = "blah"

11 { baz = "blah"

12 }

12 }

13

13

examples/passing/ObjectUpdater.pursnew file+35

@@ -0,0 +1,35 @@

1+module Main where

2+

3+import Control.Monad.Eff

4+import Debug.Trace

5+

6+foreign import eqeqeq

7+ """

8+ function eqeqeq(x) {

9+ return function (y) {

10+ if (x == y) return x;

11+ throw new Error("Unexpected result: " + x + " /== " + y);

12+ };

13+ };

14+ """ :: forall a. a -> a -> a

15+

16+(===) = eqeqeq

17+infixl 4 ===

18+

19+getValue :: forall e. Eff (| e) Boolean

20+getValue = return true

21+

22+main = do

23+ let record = { value: false }

24+ record' <- record { value = _ } <$> getValue

25+ print $ record'.value === true

26+

27+ let point = { x: 1, y: 1 }

28+ x = 10

29+ point' = (point { x = _, y = x }) 100

30+

31+ print $ point'.x === 100

32+ print $ point'.y === 10

33+

34+ let record2 = (_ { x = _ }) { x: 0 } 10

35+ print $ record2.x === 10

examples/passing/ObjectWildcards.pursnew file+31

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

1+module Main where

2+

3+import Control.Monad.Eff

4+import Debug.Trace

5+

6+mkRecord = { foo: _, bar: _, baz: "baz" }

7+

8+getValue :: forall e. Eff (| e) Boolean

9+getValue = return true

10+

11+foreign import eqeqeq

12+ """

13+ function eqeqeq(x) {

14+ return function (y) {

15+ if (x == y) return x;

16+ throw new Error("Unexpected result: " + x + " /== " + y);

17+ };

18+ };

19+ """ :: forall a. a -> a -> a

20+

21+(===) = eqeqeq

22+infixl 4 ===

23+

24+main = do

25+ obj <- { value: _ } <$> getValue

26+ print obj.value

27+ let x = 1

28+ point <- { x: _, y: x } <$> return 2

29+ print $ point.x === 2

30+ print $ point.y === 1

31+ trace (mkRecord 1 "Done!").bar

examples/passing/Objects.purs+1−1

@@ -31,5 +31,5 @@ module Main where

31 { "***": n } -> n

31 { "***": n } -> n

32

32

33 test7 {a: snoog , b : blah } = blah

33 test7 {a: snoog , b : blah } = blah

34−

34+

35 main = Debug.Trace.trace "Done"

35 main = Debug.Trace.trace "Done"

examples/passing/OneConstructor.purs+1−1

@@ -2,6 +2,6 @@ module Main where

2

2

3data One a = One a

3data One a = One a

4

4

5−one (One a) = a

5+one' (One a) = a

6

6

7main = Debug.Trace.trace "Done"

7main = Debug.Trace.trace "Done"

examples/passing/OperatorAssociativity.purs+15−9

@@ -6,20 +6,26 @@ import Debug.Trace

6foreign import data Assert :: !

6foreign import data Assert :: !

7

7

8foreign import assert

8foreign import assert

9+ """

10+ function assert(x) {

9− "function assert(x) { return function (desc) {\

11+ return function(desc) {

10− \ return function () {\

12+ return function() {

11− \ if (!x) throw new Error('assertion (' + desc + ') failed');\

13+ if (!x) throw new Error('assertion (' + desc + ') failed');

12− \ return {};\

14+ return {};

13− \ };\

15+ };

16+ };

17+ }

14− \};};" :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit

18+ """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit

15

19

16bug :: Number -> Number -> Number

20bug :: Number -> Number -> Number

17bug a b = 0 - (a - b)

21bug a b = 0 - (a - b)

18

22

19foreign import explode

23foreign import explode

24+ """

20− "function explode() {\

25+ function explode() {

21− \ throw new Error('Assertion failed!');\

26+ throw new Error('Assertion failed!');

27+ }

22− \}":: forall eff a. Eff eff a

28+ """ :: forall eff a. Eff eff a

23

29

24main = do

30main = do

25 assert (bug 0 2 == 2) "bug 0 2 == 2"

31 assert (bug 0 2 == 2) "bug 0 2 == 2"

examples/passing/OperatorSections.pursnew file+21

@@ -0,0 +1,21 @@

1+module Main where

2+

3+foreign import eqeqeq

4+ """

5+ function eqeqeq(x) {

6+ return function (y) {

7+ if (x == y) return x;

8+ throw new Error("Unexpected result: " + x + " /== " + y);

9+ };

10+ };

11+ """ :: forall a. a -> a -> a

12+

13+(===) = eqeqeq

14+infixl 4 ===

15+

16+main = do

17+ Debug.Trace.print $ (/ 2) 4 === 2

18+ Debug.Trace.print $ (2 /) 4 === 0.5

19+ Debug.Trace.print $ (`const` 1) 2 === 2

20+ Debug.Trace.print $ (1 `const`) 2 === 1

21+ Debug.Trace.trace "Done!"

examples/passing/Operators.purs+11−5

@@ -2,7 +2,7 @@ module Main where

2

2

3 import Control.Monad.Eff

3 import Control.Monad.Eff

4 import Debug.Trace

4 import Debug.Trace

5−

5+

6 (?!) :: forall a. a -> a -> a

6 (?!) :: forall a. a -> a -> a

7 (?!) x _ = x

7 (?!) x _ = x

8

8

@@ -29,7 +29,7 @@ module Main where

29

29

30 test6 = ((\x -> x) `k` 2) 3

30 test6 = ((\x -> x) `k` 2) 3

31

31

32− (<+>) :: String -> String -> String

32+ (<+>) :: String -> String -> String

33 (<+>) = \s1 s2 -> s1 ++ s2

33 (<+>) = \s1 s2 -> s1 ++ s2

34

34

35 test7 = "Hello" <+> "World!"

35 test7 = "Hello" <+> "World!"

@@ -39,7 +39,7 @@ module Main where

39

39

40 foo :: String -> String

40 foo :: String -> String

41 foo = \s -> s

41 foo = \s -> s

42−

42+

43 test8 = foo @@ "Hello World"

43 test8 = foo @@ "Hello World"

44

44

45 test9 = Main.foo @@ "Hello World"

45 test9 = Main.foo @@ "Hello World"

@@ -52,7 +52,7 @@ module Main where

52 test11 = [1, 2, 3] ... [4, 5, 6]

52 test11 = [1, 2, 3] ... [4, 5, 6]

53

53

54 test12 (<%>) a b = a <%> b

54 test12 (<%>) a b = a <%> b

55−

55+

56 test13 = \(<%>) a b -> a <%> b

56 test13 = \(<%>) a b -> a <%> b

57

57

58 test14 :: Number -> Number -> Boolean

58 test14 :: Number -> Number -> Boolean

@@ -61,7 +61,7 @@ module Main where

61 test15 :: Number -> Number -> Boolean

61 test15 :: Number -> Number -> Boolean

62 test15 a b = const false $ a `test14` b

62 test15 a b = const false $ a `test14` b

63

63

64− test16 :: Number -> Number -> Number

64+ test16 :: Number -> Number -> Number

65 test16 x y = x .|. y .&. y

65 test16 x y = x .|. y .&. y

66

66

67 test17 :: Number

67 test17 :: Number

@@ -73,6 +73,11 @@ module Main where

73 test19 :: Number

73 test19 :: Number

74 test19 = negate $ negate (-1)

74 test19 = negate $ negate (-1)

75

75

76+ test20 :: Number

77+ test20 = 1 @ 2

78+ where

79+ (@) x y = x + y * y

80+

76 main = do

81 main = do

77 let t1 = test1 1 2 (\x y -> x + y)

82 let t1 = test1 1 2 (\x y -> x + y)

78 let t2 = test2

83 let t2 = test2

@@ -93,4 +98,5 @@ module Main where

93 let t17 = test17

98 let t17 = test17

94 let t18 = test18

99 let t18 = test18

95 let t19 = test19

100 let t19 = test19

101+ let t20 = test20

96 trace "Done"

102 trace "Done"

examples/passing/OptimizerBug.purs+1−1

@@ -5,5 +5,5 @@ import Prelude

5x a = 1 + y a

5x a = 1 + y a

6

6

7y a = x a

7y a = x a

8−

8+

9main = Debug.Trace.trace "Done"

9main = Debug.Trace.trace "Done"

examples/passing/PartialFunction.purs+10−8

@@ -1,14 +1,16 @@

1module Main where

1module Main where

2

2

3foreign import testError

3foreign import testError

4+ """

4− "function testError(f) {\

5+ function testError(f) {

5− \ try {\

6+ try {

6− \ return f();\

7+ return f();

7− \ } catch (e) {\

8+ } catch (e) {

8− \ if (e instanceof Error) return 'success';\

9+ if (e instanceof Error) return 'success';

9− \ throw new Error('Pattern match failure is not Error');\

10+ throw new Error('Pattern match failure is not Error');

10− \ }\

11+ }

12+ }

11− \}" :: (Unit -> Number) -> String

13+ """ :: (Unit -> Number) -> String

12

14

13fn :: Number -> Number

15fn :: Number -> Number

14fn 0 = 0

16fn 0 = 0

examples/passing/Patterns.purs+3−3

@@ -2,7 +2,7 @@ module Main where

2

2

3 import Prelude

3 import Prelude

4

4

5− test = \x -> case x of

5+ test = \x -> case x of

6 { str = "Foo", bool = true } -> true

6 { str = "Foo", bool = true } -> true

7 { str = "Bar", bool = b } -> b

7 { str = "Bar", bool = b } -> b

8 _ -> false

8 _ -> false

@@ -17,12 +17,12 @@ module Main where

17 _ -> 0

17 _ -> 0

18

18

19

19

20− h = \o -> case o of

20+ h = \o -> case o of

21 a@[_,_,_] -> a

21 a@[_,_,_] -> a

22 _ -> []

22 _ -> []

23

23

24 isDesc :: [Number] -> Boolean

24 isDesc :: [Number] -> Boolean

25 isDesc [x, y] | x > y = true

25 isDesc [x, y] | x > y = true

26 isDesc _ = false

26 isDesc _ = false

27−

27+

28 main = Debug.Trace.trace "Done"

28 main = Debug.Trace.trace "Done"

examples/passing/Person.purs+8−6

@@ -4,13 +4,15 @@ module Main where

4

4

5 data Person = Person { name :: String, age :: Number }

5 data Person = Person { name :: String, age :: Number }

6

6

7− foreign import itoa

7+ foreign import itoa

8+ """

8− "function itoa(n) {\

9+ function itoa(n) {

9− \ return n.toString();\

10+ return n.toString();

11+ }

10− \}" :: Number -> String

12+ """ :: Number -> String

11−

13+

12 showPerson :: Person -> String

14 showPerson :: Person -> String

13 showPerson = \p -> case p of

15 showPerson = \p -> case p of

14 Person o -> o.name ++ ", aged " ++ itoa(o.age)

16 Person o -> o.name ++ ", aged " ++ itoa(o.age)

15−

17+

16 main = Debug.Trace.trace "Done"

18 main = Debug.Trace.trace "Done"

examples/passing/Rank2Data.purs+7−7

@@ -12,18 +12,18 @@ module Main where

12 runNat = \nat -> case nat of

12 runNat = \nat -> case nat of

13 Nat f -> f 0 (\n -> n + 1)

13 Nat f -> f 0 (\n -> n + 1)

14

14

15− zero = Nat (\zero _ -> zero)

15+ zero' = Nat (\zero' _ -> zero')

16

16

17 succ = \n -> case n of

17 succ = \n -> case n of

18− Nat f -> Nat (\zero succ -> succ (f zero succ))

18+ Nat f -> Nat (\zero' succ -> succ (f zero' succ))

19

19

20 add = \n m -> case n of

20 add = \n m -> case n of

21 Nat f -> case m of

21 Nat f -> case m of

22− Nat g -> Nat (\zero succ -> g (f zero succ) succ)

22+ Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)

23

23

24− one = succ zero

24+ one' = succ zero'

25− two = succ zero

25+ two = succ zero'

26 four = add two two

26 four = add two two

27 fourNumber = runNat four

27 fourNumber = runNat four

28−

28+

29− main = Debug.Trace.trace "Done"

29+ main = Debug.Trace.trace "Done'"

examples/passing/Rank2TypeSynonym.purs+2−2

@@ -3,10 +3,10 @@ module Main where

3import Control.Monad.Eff

3import Control.Monad.Eff

4

4

5type Foo a = forall f. (Monad f) => f a

5type Foo a = forall f. (Monad f) => f a

6−

6+

7foo :: forall a. a -> Foo a

7foo :: forall a. a -> Foo a

8foo x = pure x

8foo x = pure x

9−

9+

10bar :: Foo Number

10bar :: Foo Number

11bar = foo 3

11bar = foo 3

12

12

examples/passing/Rank2Types.purs+1−1

@@ -7,5 +7,5 @@ module Main where

7

7

8 forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b

8 forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b

9 forever = \bind action -> bind action $ \_ -> forever bind action

9 forever = \bind action -> bind action $ \_ -> forever bind action

10−

10+

11 main = Debug.Trace.trace "Done"

11 main = Debug.Trace.trace "Done"

examples/passing/Recursion.purs+1−1

@@ -6,5 +6,5 @@ module Main where

6 0 -> 1

6 0 -> 1

7 1 -> 1

7 1 -> 1

8 n -> fib (n - 1) + fib (n - 2)

8 n -> fib (n - 1) + fib (n - 2)

9−

9+

10 main = Debug.Trace.trace "Done"

10 main = Debug.Trace.trace "Done"

examples/passing/RowPolyInstanceContext.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

2+

3+class T s m where

4+ state :: (s -> s) -> m Unit

5+

6+data S s a = S (s -> { new :: s, ret :: a })

7+

8+instance st :: T s (S s) where

9+ state f = S $ \s -> { new: f s, ret: unit }

10+

11+test1 :: forall r . S { foo :: String | r } Unit

12+test1 = state $ \o -> o { foo = o.foo ++ "!" }

13+

14+test2 :: forall m r . (T { foo :: String | r } m) => m Unit

15+test2 = state $ \o -> o { foo = o.foo ++ "!" }

16+

17+main = do

18+ let t1 = test1

19+ let t2 = test2

20+ Debug.Trace.trace "Done"

examples/passing/RowSynonyms.pursnew file+46

@@ -0,0 +1,46 @@

1+module Main where

2+

3+import Control.Monad.Eff

4+import Control.Monad.ST

5+

6+type State bindings =

7+ {

8+ bindings :: {addition :: Number | bindings},

9+ other :: String

10+ }

11+

12+type MyBindings = (test :: Number)

13+

14+data Shadow bindings = Shadow String

15+

16+shadows :: Shadow (Object MyBindings)

17+shadows = Shadow "uhh"

18+

19+main :: Eff () Unit

20+main = withIt

21+ shadows

22+ \ bindings -> do

23+ let state =

24+ {

25+ bindings : bindings,

26+ other : "Test"

27+ }

28+ runST do

29+ stRef <- newSTRef state

30+ handleKeyD stRef

31+ return unit

32+

33+

34+withIt :: forall bindings eff a. Shadow (Object bindings) ->

35+ ({addition :: Number | bindings} -> Eff eff a) -> Eff eff a

36+withIt (Shadow str) success = do

37+ b <- withBindings

38+ success (b{addition = 1})

39+

40+foreign import withBindings

41+"""

42+ function withBindings() {}

43+""" :: forall eff bindings. Eff eff bindings

44+

45+handleKeyD :: forall h eff. STRef h (State MyBindings) -> Eff (st :: ST h | eff) Unit

46+handleKeyD state = return unit

examples/passing/ScopedTypeVariables.pursnew file+34

@@ -0,0 +1,34 @@

1+module Main where

2+

3+test1 :: forall a. (a -> a) -> a -> a

4+test1 f x = g (g x)

5+ where

6+ g :: a -> a

7+ g y = f (f y)

8+

9+test2 :: forall a. (a -> a) -> a -> a

10+test2 = h

11+ where

12+ h :: forall b. (b -> b) -> b -> b

13+ h f x = g (g x)

14+ where

15+ g :: b -> b

16+ g y = f (f y)

17+

18+test3 :: Number

19+test3 = ((\b -> b :: b) :: forall b. b -> b) 0

20+

21+test4 :: forall a. (a -> a) -> a -> a

22+test4 = h

23+ where

24+ h :: forall b. (b -> b) -> b -> b

25+ h f x = g (g x)

26+ where

27+ g :: b -> b

28+ g y = j (f (f y))

29+ where

30+ j :: forall b. b -> b

31+ j x = x

32+

33+

34+main = Debug.Trace.trace "Done"

examples/passing/Sequence.purs+2−2

@@ -4,9 +4,9 @@ import Control.Monad.Eff

4

4

5class Sequence t where

5class Sequence t where

6 sequence :: forall m a. (Monad m) => t (m a) -> m (t a)

6 sequence :: forall m a. (Monad m) => t (m a) -> m (t a)

7−

7+

8instance sequenceArray :: Sequence [] where

8instance sequenceArray :: Sequence [] where

9 sequence [] = pure []

9 sequence [] = pure []

10− sequence (x:xs) = (:) <$> x <*> sequence xs

10+ sequence (x:xs) = (:) <$> x <*> sequence xs

11

11

12main = sequence $ [Debug.Trace.trace "Done"]

12main = sequence $ [Debug.Trace.trace "Done"]

examples/passing/ShadowedRename.purs+7−5

@@ -4,11 +4,13 @@ import Control.Monad.Eff

4import Debug.Trace

4import Debug.Trace

5

5

6foreign import f

6foreign import f

7+ """

7− "function f(x) {\

8+ function f(x) {

8− \ return function () {\

9+ return function() {

9− \ if (x !== 2) throw new Error('x is not 2');\

10+ if (x !== 2) throw new Error('x is not 2');

11+ };

10− \ }\

12+ }

11− \}" :: forall e. Number -> Eff e Number

13+ """ :: forall e. Number -> Eff e Number

12

14

13foo foo = let foo_1 = \_ -> foo

15foo foo = let foo_1 = \_ -> foo

14 foo_2 = foo_1 unit + 1

16 foo_2 = foo_1 unit + 1

examples/passing/ShadowedTCO.purs+5−5

@@ -2,14 +2,14 @@ module Main where

2

2

3runNat f = f 0 (\n -> n + 1)

3runNat f = f 0 (\n -> n + 1)

4

4

5−zero z _ = z

5+zero' z _ = z

6

6

7−succ f zero succ = succ (f zero succ)

7+succ f zero' succ = succ (f zero' succ)

8

8

9−add f g zero succ = g (f zero succ) succ

9+add f g zero' succ = g (f zero' succ) succ

10

10

11−one = succ zero

11+one' = succ zero'

12−two = succ one

12+two = succ one'

13four = add two two

13four = add two two

14fourNumber = runNat four

14fourNumber = runNat four

15

15

examples/passing/ShadowedTCOLet.purs+3−3

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

1module Main where

1module Main where

2

2

3−f x y z =

3+f x y z =

4− let f 1 2 3 = 1

4+ let f 1 2 3 = 1

5 in f x z y

5 in f x z y

6−

6+

7main = Debug.Trace.trace $ show $ f 1 3 2

7main = Debug.Trace.trace $ show $ f 1 3 2

examples/passing/SignedNumericLiterals.purs+2−2

@@ -6,10 +6,10 @@ module Main where

6 y = -0.5

6 y = -0.5

7 z = 0.5

7 z = 0.5

8 w = 1

8 w = 1

9−

9+

10 f :: Number -> Number

10 f :: Number -> Number

11 f x = -x

11 f x = -x

12

12

13 test1 = 2 - 1

13 test1 = 2 - 1

14−

14+

15 main = Debug.Trace.trace "Done"

15 main = Debug.Trace.trace "Done"

examples/passing/Superclasses3.purs+1−1

@@ -33,7 +33,7 @@ instance applicativeMTrace :: Applicative MTrace where

33instance bindMTrace :: Bind MTrace where

33instance bindMTrace :: Bind MTrace where

34 (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))

34 (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))

35

35

36−instance monadMTrace :: Monad MTrace

36+instance monadMTrace :: Monad MTrace

37

37

38instance writerMTrace :: MonadWriter String MTrace where

38instance writerMTrace :: MonadWriter String MTrace where

39 tell s = MTrace (trace s)

39 tell s = MTrace (trace s)

examples/passing/TailCall.purs+2−2

@@ -9,7 +9,7 @@ test n (x:xs) = test (n + x) xs

9loop :: forall a. Number -> a

9loop :: forall a. Number -> a

10loop x = loop (x + 1)

10loop x = loop (x + 1)

11

11

12−notATailCall = \x ->

12+notATailCall = \x ->

13 (\notATailCall -> notATailCall x) (\x -> x)

13 (\notATailCall -> notATailCall x) (\x -> x)

14−

14+

15main = Debug.Trace.print (test 0 [1, 2, 3])

15main = Debug.Trace.print (test 0 [1, 2, 3])

examples/passing/TopLevelCase.purs+1−1

@@ -14,5 +14,5 @@ module Main where

14 data A = A

14 data A = A

15

15

16 parseTest A 0 = 0

16 parseTest A 0 = 0

17−

17+

18 main = Debug.Trace.trace "Done"

18 main = Debug.Trace.trace "Done"

examples/passing/TypeClassImport.purs+3−3

@@ -7,9 +7,9 @@ foreign import data C :: *

7foreign import t "var t = null;" :: T

7foreign import t "var t = null;" :: T

8

8

9foreign import inst """

9foreign import inst """

10− var inst = {

10+ var inst = {

11− show: function(t) {

11+ show: function(t) {

12− return 'Done';

12+ return 'Done';

13 }

13 }

14 }""" :: C

14 }""" :: C

15

15

examples/passing/TypeClassMemberOrderChange.purs+1−1

@@ -3,7 +3,7 @@ module Main where

3class Test a where

3class Test a where

4 fn :: a -> a -> a

4 fn :: a -> a -> a

5 val :: a

5 val :: a

6−

6+

7instance testBoolean :: Test Boolean where

7instance testBoolean :: Test Boolean where

8 val = true

8 val = true

9 fn x y = y

9 fn x y = y

examples/passing/TypeDecl.purs+1−1

@@ -8,5 +8,5 @@ module Main where

8 iterate :: forall a. Number -> (a -> a) -> a -> a

8 iterate :: forall a. Number -> (a -> a) -> a -> a

9 iterate 0 f a = a

9 iterate 0 f a = a

10 iterate n f a = iterate (n - 1) f (f a)

10 iterate n f a = iterate (n - 1) f (f a)

11−

11+

12 main = Debug.Trace.trace "Done"

12 main = Debug.Trace.trace "Done"

examples/passing/TypeSynonyms.purs+2−2

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

1module Main where

1module Main where

2

2

3− type Lens a b =

3+ type Lens a b =

4 { get :: a -> b

4 { get :: a -> b

5 , set :: a -> b -> a

5 , set :: a -> b -> a

6 }

6 }

@@ -14,7 +14,7 @@ module Main where

14 type Pair a b = { fst :: a, snd :: b }

14 type Pair a b = { fst :: a, snd :: b }

15

15

16 fst :: forall a b. Lens (Pair a b) a

16 fst :: forall a b. Lens (Pair a b) a

17− fst =

17+ fst =

18 { get: \p -> p.fst

18 { get: \p -> p.fst

19 , set: \p a -> { fst: a, snd: p.snd }

19 , set: \p a -> { fst: a, snd: p.snd }

20 }

20 }

examples/passing/TypeWildcardsRecordExtension.purs+1−1

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

1module Main where

1module Main where

2−

2+

3foo :: forall a. {b :: Number | a} -> {b :: Number | _}

3foo :: forall a. {b :: Number | a} -> {b :: Number | _}

4foo f = f

4foo f = f

5

5

examples/passing/Where.purs+6−6

@@ -7,24 +7,24 @@ import Control.Monad.ST

7test1 x = y

7test1 x = y

8 where

8 where

9 y :: Number

9 y :: Number

10− y = x + 1

10+ y = x + 1

11

11

12test2 x y = x' + y'

12test2 x y = x' + y'

13 where

13 where

14 x' = x + 1

14 x' = x + 1

15 y' = y + 1

15 y' = y + 1

16−

16+

17

17

18test3 = f 1 2 3

18test3 = f 1 2 3

19 where f x y z = x + y + z

19 where f x y z = x + y + z

20−

20+

21

21

22test4 = f (+) [1, 2]

22test4 = f (+) [1, 2]

23 where f x [y, z] = x y z

23 where f x [y, z] = x y z

24−

24+

25

25

26test5 = g 10

26test5 = g 10

27− where

27+ where

28 f x | x > 0 = g (x / 2) + 1

28 f x | x > 0 = g (x / 2) + 1

29 f x = 0

29 f x = 0

30 g x = f (x - 1) + 1

30 g x = f (x - 1) + 1

@@ -35,7 +35,7 @@ test6 = if f true then f 1 else f 2

35

35

36test7 :: Number -> Number

36test7 :: Number -> Number

37test7 x = go x

37test7 x = go x

38− where

38+ where

39 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

39 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

40 go y = go $ (y + x / y) / 2

40 go y = go $ (y + x / y) / 2

41

41

examples/passing/s.purs+1−1

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

1module Main where

1module Main where

2

2

3 s = \x y z -> x z (y z)

3 s = \x y z -> x z (y z)

4−

4+

5 main = Debug.Trace.trace "Done"

5 main = Debug.Trace.trace "Done"

prelude/README.md+343−33

@@ -4,28 +4,40 @@

4

4

5### Types

5### Types

6

6

7− data Ordering where

8− LT :: Ordering

9− GT :: Ordering

10− EQ :: Ordering

7+#### `Ordering`

11

8

9+ data Ordering

10+ = LT

11+ | GT

12+ | EQ

13+

14+#### `Unit`

15+

12− newtype Unit where

16+ newtype Unit

13− Unit :: { } -> Unit

17+ = Unit { }

14

18

15

19

16### Type Classes

20### Type Classes

17

21

18

22

19

23

24+#### `Applicative`

25+

20 class (Apply f) <= Applicative f where

26 class (Apply f) <= Applicative f where

21 pure :: forall a. a -> f a

27 pure :: forall a. a -> f a

22

28

29+#### `Apply`

30+

23 class (Functor f) <= Apply f where

31 class (Functor f) <= Apply f where

24 (<*>) :: forall a b. f (a -> b) -> f a -> f b

32 (<*>) :: forall a b. f (a -> b) -> f a -> f b

25

33

34+#### `Bind`

35+

26 class (Apply m) <= Bind m where

36 class (Apply m) <= Bind m where

27 (>>=) :: forall a b. m a -> (a -> m b) -> m b

37 (>>=) :: forall a b. m a -> (a -> m b) -> m b

28

38

39+#### `Bits`

40+

29 class Bits b where

41 class Bits b where

30 (.&.) :: b -> b -> b

42 (.&.) :: b -> b -> b

31 (.|.) :: b -> b -> b

43 (.|.) :: b -> b -> b

@@ -35,153 +47,349 @@

35 zshr :: b -> Number -> b

47 zshr :: b -> Number -> b

36 complement :: b -> b

48 complement :: b -> b

37

49

50+#### `BoolLike`

51+

38 class BoolLike b where

52 class BoolLike b where

39 (&&) :: b -> b -> b

53 (&&) :: b -> b -> b

40 (||) :: b -> b -> b

54 (||) :: b -> b -> b

41 not :: b -> b

55 not :: b -> b

42

56

57+#### `Category`

58+

43 class (Semigroupoid a) <= Category a where

59 class (Semigroupoid a) <= Category a where

44 id :: forall t. a t t

60 id :: forall t. a t t

45

61

62+#### `DivisionRing`

63+

64+Ring where every nonzero element has a multiplicative inverse (possibly

65+a non-commutative field) so that ```a `mod` b = zero```

66+

67+ class (Ring a, ModuloSemiring a) <= DivisionRing a where

68+

69+#### `Eq`

70+

46 class Eq a where

71 class Eq a where

47 (==) :: a -> a -> Boolean

72 (==) :: a -> a -> Boolean

48 (/=) :: a -> a -> Boolean

73 (/=) :: a -> a -> Boolean

49

74

75+#### `Functor`

76+

50 class Functor f where

77 class Functor f where

51 (<$>) :: forall a b. (a -> b) -> f a -> f b

78 (<$>) :: forall a b. (a -> b) -> f a -> f b

52

79

53− class (Applicative m, Bind m) <= Monad m where

80+#### `ModuloSemiring`

54

81

55− class Num a where

82+Semiring with modulo operation and division where

56− (+) :: a -> a -> a

83+```a / b * b + (a `mod` b) = a```

57− (-) :: a -> a -> a

84+

58− (*) :: a -> a -> a

85+ class (Semiring a) <= ModuloSemiring a where

59 (/) :: a -> a -> a

86 (/) :: a -> a -> a

60− (%) :: a -> a -> a

87+ mod :: a -> a -> a

61− negate :: a -> a

88+

89+#### `Monad`

90+

91+ class (Applicative m, Bind m) <= Monad m where

92+

93+#### `Num`

94+

95+A commutative field

96+

97+ class (DivisionRing a) <= Num a where

98+

99+#### `Ord`

62

100

63 class (Eq a) <= Ord a where

101 class (Eq a) <= Ord a where

64 compare :: a -> a -> Ordering

102 compare :: a -> a -> Ordering

65

103

104+#### `Ring`

105+

106+Addition, multiplication, and subtraction

107+

108+ class (Semiring a) <= Ring a where

109+ (-) :: a -> a -> a

110+

111+#### `Semigroup`

112+

66 class Semigroup a where

113 class Semigroup a where

67 (<>) :: a -> a -> a

114 (<>) :: a -> a -> a

68

115

116+#### `Semigroupoid`

117+

69 class Semigroupoid a where

118 class Semigroupoid a where

70 (<<<) :: forall b c d. a c d -> a b c -> a b d

119 (<<<) :: forall b c d. a c d -> a b c -> a b d

71

120

121+#### `Semiring`

122+

123+Addition and multiplication

124+

125+ class Semiring a where

126+ (+) :: a -> a -> a

127+ zero :: a

128+ (*) :: a -> a -> a

129+ one :: a

130+

131+#### `Show`

132+

72 class Show a where

133 class Show a where

73 show :: a -> String

134 show :: a -> String

74

135

75

136

76### Type Class Instances

137### Type Class Instances

77

138

139+#### `applicativeArr`

140+

78 instance applicativeArr :: Applicative (Prim.Function r)

141 instance applicativeArr :: Applicative (Prim.Function r)

79

142

143+#### `applyArr`

144+

80 instance applyArr :: Apply (Prim.Function r)

145 instance applyArr :: Apply (Prim.Function r)

81

146

147+#### `bindArr`

148+

82 instance bindArr :: Bind (Prim.Function r)

149 instance bindArr :: Bind (Prim.Function r)

83

150

151+#### `bitsNumber`

152+

84 instance bitsNumber :: Bits Number

153 instance bitsNumber :: Bits Number

85

154

155+#### `boolLikeBoolean`

156+

86 instance boolLikeBoolean :: BoolLike Boolean

157 instance boolLikeBoolean :: BoolLike Boolean

87

158

159+#### `categoryArr`

160+

88 instance categoryArr :: Category Prim.Function

161 instance categoryArr :: Category Prim.Function

89

162

163+#### `divisionRingNumber`

164+

165+ instance divisionRingNumber :: DivisionRing Number

166+

167+#### `eqArray`

168+

90 instance eqArray :: (Eq a) => Eq [a]

169 instance eqArray :: (Eq a) => Eq [a]

91

170

171+#### `eqBoolean`

172+

92 instance eqBoolean :: Eq Boolean

173 instance eqBoolean :: Eq Boolean

93

174

175+#### `eqNumber`

176+

94 instance eqNumber :: Eq Number

177 instance eqNumber :: Eq Number

95

178

179+#### `eqOrdering`

180+

96 instance eqOrdering :: Eq Ordering

181 instance eqOrdering :: Eq Ordering

97

182

183+#### `eqString`

184+

98 instance eqString :: Eq String

185 instance eqString :: Eq String

99

186

187+#### `eqUnit`

188+

100 instance eqUnit :: Eq Unit

189 instance eqUnit :: Eq Unit

101

190

191+#### `functorArr`

192+

102 instance functorArr :: Functor (Prim.Function r)

193 instance functorArr :: Functor (Prim.Function r)

103

194

195+#### `moduloSemiringNumber`

196+

197+ instance moduloSemiringNumber :: ModuloSemiring Number

198+

199+#### `monadArr`

200+

104 instance monadArr :: Monad (Prim.Function r)

201 instance monadArr :: Monad (Prim.Function r)

105

202

203+#### `numNumber`

204+

106 instance numNumber :: Num Number

205 instance numNumber :: Num Number

107

206

207+#### `ordArray`

208+

108 instance ordArray :: (Ord a) => Ord [a]

209 instance ordArray :: (Ord a) => Ord [a]

109

210

211+#### `ordBoolean`

212+

110 instance ordBoolean :: Ord Boolean

213 instance ordBoolean :: Ord Boolean

111

214

215+#### `ordNumber`

216+

112 instance ordNumber :: Ord Number

217 instance ordNumber :: Ord Number

113

218

219+#### `ordString`

220+

114 instance ordString :: Ord String

221 instance ordString :: Ord String

115

222

223+#### `ordUnit`

224+

116 instance ordUnit :: Ord Unit

225 instance ordUnit :: Ord Unit

117

226

227+#### `ringNumber`

228+

229+ instance ringNumber :: Ring Number

230+

231+#### `semigroupArr`

232+

118 instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')

233 instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')

119

234

235+#### `semigroupString`

236+

120 instance semigroupString :: Semigroup String

237 instance semigroupString :: Semigroup String

121

238

239+#### `semigroupUnit`

240+

122 instance semigroupUnit :: Semigroup Unit

241 instance semigroupUnit :: Semigroup Unit

123

242

243+#### `semigroupoidArr`

244+

124 instance semigroupoidArr :: Semigroupoid Prim.Function

245 instance semigroupoidArr :: Semigroupoid Prim.Function

125

246

247+#### `semiringNumber`

248+

249+ instance semiringNumber :: Semiring Number

250+

251+#### `showArray`

252+

126 instance showArray :: (Show a) => Show [a]

253 instance showArray :: (Show a) => Show [a]

127

254

255+#### `showBoolean`

256+

128 instance showBoolean :: Show Boolean

257 instance showBoolean :: Show Boolean

129

258

259+#### `showNumber`

260+

130 instance showNumber :: Show Number

261 instance showNumber :: Show Number

131

262

263+#### `showOrdering`

264+

132 instance showOrdering :: Show Ordering

265 instance showOrdering :: Show Ordering

133

266

267+#### `showString`

268+

134 instance showString :: Show String

269 instance showString :: Show String

135

270

271+#### `showUnit`

272+

136 instance showUnit :: Show Unit

273 instance showUnit :: Show Unit

137

274

138

275

139### Values

276### Values

140

277

278+#### `(#)`

279+

141 (#) :: forall a b. a -> (a -> b) -> b

280 (#) :: forall a b. a -> (a -> b) -> b

142

281

282+#### `($)`

283+

143 ($) :: forall a b. (a -> b) -> a -> b

284 ($) :: forall a b. (a -> b) -> a -> b

144

285

286+#### `(++)`

287+

145 (++) :: forall s. (Semigroup s) => s -> s -> s

288 (++) :: forall s. (Semigroup s) => s -> s -> s

146

289

290+#### `(:)`

291+

147 (:) :: forall a. a -> [a] -> [a]

292 (:) :: forall a. a -> [a] -> [a]

148

293

294+#### `(<#>)`

295+

149 (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b

296 (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b

150

297

298+#### `(<)`

299+

151 (<) :: forall a. (Ord a) => a -> a -> Boolean

300 (<) :: forall a. (Ord a) => a -> a -> Boolean

152

301

302+#### `(<=)`

303+

153 (<=) :: forall a. (Ord a) => a -> a -> Boolean

304 (<=) :: forall a. (Ord a) => a -> a -> Boolean

154

305

306+#### `(>)`

307+

155 (>) :: forall a. (Ord a) => a -> a -> Boolean

308 (>) :: forall a. (Ord a) => a -> a -> Boolean

156

309

310+#### `(>=)`

311+

157 (>=) :: forall a. (Ord a) => a -> a -> Boolean

312 (>=) :: forall a. (Ord a) => a -> a -> Boolean

158

313

314+#### `(>>>)`

315+

159 (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d

316 (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d

160

317

318+#### `ap`

319+

161 ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b

320 ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b

162

321

322+#### `asTypeOf`

323+

324+This function returns its first argument, and can be used to assert type equalities.

325+This can be useful when types are otherwise ambiguous.

326+

327+E.g.

328+

329+ main = print $ [] `asTypeOf` [0]

330+

331+If instead, we had written `main = print []`, the type of the argument `[]` would have

332+been ambiguous, resulting in a compile-time error.

333+

163 asTypeOf :: forall a. a -> a -> a

334 asTypeOf :: forall a. a -> a -> a

164

335

336+#### `cons`

337+

165 cons :: forall a. a -> [a] -> [a]

338 cons :: forall a. a -> [a] -> [a]

166

339

340+#### `const`

341+

342+Returns its first argument and ignores its second.

343+

167 const :: forall a b. a -> b -> a

344 const :: forall a b. a -> b -> a

168

345

346+#### `flip`

347+

348+Flips the order of the arguments to a function of two arguments.

349+

169 flip :: forall a b c. (a -> b -> c) -> b -> a -> c

350 flip :: forall a b c. (a -> b -> c) -> b -> a -> c

170

351

352+#### `liftA1`

353+

171 liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

354 liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

172

355

356+#### `liftM1`

357+

173 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

358 liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

174

359

360+#### `negate`

361+

362+ negate :: forall a. (Ring a) => a -> a

363+

364+#### `otherwise`

365+

366+An alias for `true`, which can be useful in guard clauses:

367+

368+E.g.

369+

370+ max x y | x >= y = x

371+ | otherwise = y

372+

175 otherwise :: Boolean

373 otherwise :: Boolean

176

374

375+#### `refEq`

376+

177 refEq :: forall a. a -> a -> Boolean

377 refEq :: forall a. a -> a -> Boolean

178

378

379+#### `refIneq`

380+

179 refIneq :: forall a. a -> a -> Boolean

381 refIneq :: forall a. a -> a -> Boolean

180

382

383+#### `return`

384+

181 return :: forall m a. (Monad m) => a -> m a

385 return :: forall m a. (Monad m) => a -> m a

182

386

387+#### `unit`

388+

183 unit :: Unit

389 unit :: Unit

184

390

391+#### `void`

392+

185 void :: forall f a. (Functor f) => f a -> f Unit

393 void :: forall f a. (Functor f) => f a -> f Unit

186

394

187

395

@@ -189,102 +397,152 @@

189

397

190### Types

398### Types

191

399

400+#### `Fn0`

401+

192 data Fn0 :: * -> *

402 data Fn0 :: * -> *

193

403

404+#### `Fn1`

405+

194 data Fn1 :: * -> * -> *

406 data Fn1 :: * -> * -> *

195

407

408+#### `Fn10`

409+

196 data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

410 data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

197

411

412+#### `Fn2`

413+

198 data Fn2 :: * -> * -> * -> *

414 data Fn2 :: * -> * -> * -> *

199

415

416+#### `Fn3`

417+

200 data Fn3 :: * -> * -> * -> * -> *

418 data Fn3 :: * -> * -> * -> * -> *

201

419

420+#### `Fn4`

421+

202 data Fn4 :: * -> * -> * -> * -> * -> *

422 data Fn4 :: * -> * -> * -> * -> * -> *

203

423

424+#### `Fn5`

425+

204 data Fn5 :: * -> * -> * -> * -> * -> * -> *

426 data Fn5 :: * -> * -> * -> * -> * -> * -> *

205

427

428+#### `Fn6`

429+

206 data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *

430 data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *

207

431

432+#### `Fn7`

433+

208 data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *

434 data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *

209

435

436+#### `Fn8`

437+

210 data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *

438 data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *

211

439

440+#### `Fn9`

441+

212 data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

442 data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

213

443

214

444

215### Values

445### Values

216

446

447+#### `mkFn0`

448+

217 mkFn0 :: forall a. (Unit -> a) -> Fn0 a

449 mkFn0 :: forall a. (Unit -> a) -> Fn0 a

218

450

451+#### `mkFn1`

452+

219 mkFn1 :: forall a b. (a -> b) -> Fn1 a b

453 mkFn1 :: forall a b. (a -> b) -> Fn1 a b

220

454

455+#### `mkFn10`

456+

221 mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k

457 mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k

222

458

459+#### `mkFn2`

460+

223 mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c

461 mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c

224

462

463+#### `mkFn3`

464+

225 mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

465 mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

226

466

467+#### `mkFn4`

468+

227 mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

469 mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

228

470

471+#### `mkFn5`

472+

229 mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

473 mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

230

474

475+#### `mkFn6`

476+

231 mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g

477 mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g

232

478

479+#### `mkFn7`

480+

233 mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h

481 mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h

234

482

483+#### `mkFn8`

484+

235 mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i

485 mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i

236

486

487+#### `mkFn9`

488+

237 mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j

489 mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j

238

490

491+#### `on`

492+

239 on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c

493 on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c

240

494

241− runFn0 :: forall a. Fn0 a -> a

495+#### `runFn0`

242

496

243− runFn1 :: forall a b. Fn1 a b -> a -> b

497+ runFn0 :: forall a. Fn0 a -> a

244

498

245− runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k

499+#### `runFn1`

246

500

247− runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c

501+ runFn1 :: forall a b. Fn1 a b -> a -> b

248

502

249− runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

503+#### `runFn10`

250

504

251− runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

505+ runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k

252

506

253− runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

507+#### `runFn2`

254

508

255− runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g

509+ runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c

256

510

257− runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h

511+#### `runFn3`

258

512

259− runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i

513+ runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

260

514

261− runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j

515+#### `runFn4`

262

516

517+ runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

263

518

264−## Module Data.Eq

519+#### `runFn5`

265

520

266−### Types

521+ runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

267

522

268− newtype Ref a where

523+#### `runFn6`

269− Ref :: a -> Ref a

270

524

525+ runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g

271

526

272−### Type Class Instances

527+#### `runFn7`

273

528

274− instance eqRef :: Eq (Ref a)

529+ runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h

275

530

276− instance functorRef :: Functor Ref

531+#### `runFn8`

277

532

533+ runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i

278

534

279−### Values

535+#### `runFn9`

280

536

281− liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b

537+ runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j

282

538

283

539

284## Module Prelude.Unsafe

540## Module Prelude.Unsafe

285

541

286### Values

542### Values

287

543

544+#### `unsafeIndex`

545+

288 unsafeIndex :: forall a. [a] -> Number -> a

546 unsafeIndex :: forall a. [a] -> Number -> a

289

547

290

548

@@ -292,38 +550,66 @@

292

550

293### Types

551### Types

294

552

553+#### `Eff`

554+

295 data Eff :: # ! -> * -> *

555 data Eff :: # ! -> * -> *

296

556

557+#### `Pure`

558+

297 type Pure a = forall e. Eff e a

559 type Pure a = forall e. Eff e a

298

560

299

561

300### Type Class Instances

562### Type Class Instances

301

563

564+#### `applicativeEff`

565+

302 instance applicativeEff :: Applicative (Eff e)

566 instance applicativeEff :: Applicative (Eff e)

303

567

568+#### `applyEff`

569+

304 instance applyEff :: Apply (Eff e)

570 instance applyEff :: Apply (Eff e)

305

571

572+#### `bindEff`

573+

306 instance bindEff :: Bind (Eff e)

574 instance bindEff :: Bind (Eff e)

307

575

576+#### `functorEff`

577+

308 instance functorEff :: Functor (Eff e)

578 instance functorEff :: Functor (Eff e)

309

579

580+#### `monadEff`

581+

310 instance monadEff :: Monad (Eff e)

582 instance monadEff :: Monad (Eff e)

311

583

312

584

313### Values

585### Values

314

586

587+#### `bindE`

588+

315 bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

589 bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

316

590

591+#### `forE`

592+

317 forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

593 forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

318

594

595+#### `foreachE`

596+

319 foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

597 foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

320

598

599+#### `returnE`

600+

321 returnE :: forall e a. a -> Eff e a

601 returnE :: forall e a. a -> Eff e a

322

602

603+#### `runPure`

604+

323 runPure :: forall a. Pure a -> a

605 runPure :: forall a. Pure a -> a

324

606

607+#### `untilE`

608+

325 untilE :: forall e. Eff e Boolean -> Eff e Unit

609 untilE :: forall e. Eff e Boolean -> Eff e Unit

326

610

611+#### `whileE`

612+

327 whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

613 whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

328

614

329

615

@@ -331,6 +617,8 @@

331

617

332### Values

618### Values

333

619

620+#### `unsafeInterleaveEff`

621+

334 unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

622 unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

335

623

336

624

@@ -338,13 +626,19 @@

338

626

339### Types

627### Types

340

628

629+#### `Trace`

630+

341 data Trace :: !

631 data Trace :: !

342

632

343

633

344### Values

634### Values

345

635

636+#### `print`

637+

346 print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit

638 print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit

347

639

640+#### `trace`

641+

348 trace :: forall r. String -> Eff (trace :: Trace | r) Unit

642 trace :: forall r. String -> Eff (trace :: Trace | r) Unit

349

643

350

644

@@ -352,23 +646,39 @@

352

646

353### Types

647### Types

354

648

649+#### `ST`

650+

355 data ST :: * -> !

651 data ST :: * -> !

356

652

653+#### `STRef`

654+

357 data STRef :: * -> * -> *

655 data STRef :: * -> * -> *

358

656

359

657

360### Values

658### Values

361

659

660+#### `modifySTRef`

661+

362 modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

662 modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

363

663

664+#### `newSTRef`

665+

364 newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

666 newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

365

667

668+#### `pureST`

669+

366 pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a

670 pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a

367

671

672+#### `readSTRef`

673+

368 readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

674 readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

369

675

676+#### `runST`

677+

370 runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

678 runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

371

679

680+#### `writeSTRef`

681+

372 writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

682 writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

373

683

374

684

prelude/images/Prelude.png

Binary file not shown.

prelude/prelude.purs+62−17

@@ -13,8 +13,13 @@ module Prelude

13 , Applicative, pure, liftA1

13 , Applicative, pure, liftA1

14 , Bind, (>>=)

14 , Bind, (>>=)

15 , Monad, return, liftM1, ap

15 , Monad, return, liftM1, ap

16− , Num, (+), (-), (*), (/), (%)

16+ , Semiring, (+), zero, (*), one

17+ , ModuloSemiring, (/), mod

18+ , Ring, (-)

19+ , (%)

17 , negate

20 , negate

21+ , DivisionRing

22+ , Num

18 , Eq, (==), (/=), refEq, refIneq

23 , Eq, (==), (/=), refEq, refIneq

19 , Ord, Ordering(..), compare, (<), (>), (<=), (>=)

24 , Ord, Ordering(..), compare, (<), (>), (<=), (>=)

20 , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement

25 , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement

@@ -24,15 +29,32 @@ module Prelude

24 , Unit(..), unit

29 , Unit(..), unit

25 ) where

30 ) where

26

31

32+ -- | An alias for `true`, which can be useful in guard clauses:

33+ -- |

34+ -- | E.g.

35+ -- |

36+ -- | max x y | x >= y = x

37+ -- | | otherwise = y

27 otherwise :: Boolean

38 otherwise :: Boolean

28 otherwise = true

39 otherwise = true

29

40

41+ -- | Flips the order of the arguments to a function of two arguments.

30 flip :: forall a b c. (a -> b -> c) -> b -> a -> c

42 flip :: forall a b c. (a -> b -> c) -> b -> a -> c

31 flip f b a = f a b

43 flip f b a = f a b

32

44

45+ -- | Returns its first argument and ignores its second.

33 const :: forall a b. a -> b -> a

46 const :: forall a b. a -> b -> a

34 const a _ = a

47 const a _ = a

35

48

49+ -- | This function returns its first argument, and can be used to assert type equalities.

50+ -- | This can be useful when types are otherwise ambiguous.

51+ -- |

52+ -- | E.g.

53+ -- |

54+ -- | main = print $ [] `asTypeOf` [0]

55+ -- |

56+ -- | If instead, we had written `main = print []`, the type of the argument `[]` would have

57+ -- | been ambiguous, resulting in a compile-time error.

36 asTypeOf :: forall a. a -> a -> a

58 asTypeOf :: forall a. a -> a -> a

37 asTypeOf x _ = x

59 asTypeOf x _ = x

38

60

@@ -188,13 +210,32 @@ module Prelude

188 infixl 6 -

210 infixl 6 -

189 infixl 6 +

211 infixl 6 +

190

212

213+ -- | Addition and multiplication

191− class Num a where

214+ class Semiring a where

192− (+) :: a -> a -> a

215+ (+) :: a -> a -> a

216+ zero :: a

193− (-) :: a -> a -> a

217+ (*) :: a -> a -> a

194− (*) :: a -> a -> a

218+ one :: a

219+

220+ -- | Semiring with modulo operation and division where

221+ -- | ```a / b * b + (a `mod` b) = a```

222+ class (Semiring a) <= ModuloSemiring a where

195 (/) :: a -> a -> a

223 (/) :: a -> a -> a

224+ mod :: a -> a -> a

225+

226+ -- | Addition, multiplication, and subtraction

227+ class (Semiring a) <= Ring a where

196− (%) :: a -> a -> a

228+ (-) :: a -> a -> a

229+

197− negate :: a -> a

230+ negate :: forall a. (Ring a) => a -> a

231+ negate a = zero - a

232+

233+ -- | Ring where every nonzero element has a multiplicative inverse (possibly

234+ -- | a non-commutative field) so that ```a `mod` b = zero```

235+ class (Ring a, ModuloSemiring a) <= DivisionRing a

236+

237+ -- | A commutative field

238+ class (DivisionRing a) <= Num a

198

239

199 foreign import numAdd

240 foreign import numAdd

200 """

241 """

@@ -241,20 +282,24 @@ module Prelude

241 }

282 }

242 """ :: Number -> Number -> Number

283 """ :: Number -> Number -> Number

243

284

244− foreign import numNegate

285+ (%) = numMod

245− """

246− function numNegate(n) {

247− return -n;

248− }

249− """ :: Number -> Number

250

286

251− instance numNumber :: Num Number where

287+ instance semiringNumber :: Semiring Number where

252 (+) = numAdd

288 (+) = numAdd

253− (-) = numSub

289+ zero = 0

254 (*) = numMul

290 (*) = numMul

291+ one = 1

292+

293+ instance ringNumber :: Ring Number where

294+ (-) = numSub

295+

296+ instance moduloSemiringNumber :: ModuloSemiring Number where

255 (/) = numDiv

297 (/) = numDiv

256− (%) = numMod

298+ mod _ _ = 0

257− negate = numNegate

299+

300+ instance divisionRingNumber :: DivisionRing Number

301+

302+ instance numNumber :: Num Number

258

303

259 newtype Unit = Unit {}

304 newtype Unit = Unit {}

260

305

prelude/updateDocs.sh+1−1

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

1../dist/build/psc-docs/psc-docs --hierarchy-images prelude.purs > README.md

1../dist/build/psc-docs/psc-docs --hierarchy-images prelude.purs > README.md

2−../dist/build/hierarchy/hierarchy prelude.purs -o prelude

2+../dist/build/psc-hierarchy/psc-hierarchy prelude.purs -o prelude

3

3

4mkdir -p images

4mkdir -p images

5

5

psc-docs/Main.hs+72−37

@@ -22,27 +22,26 @@ import Data.Function (on)

22import Data.List

22import Data.List

23import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

24import Data.Version (showVersion)

24import Data.Version (showVersion)

25+import Data.Foldable (traverse_)

25

26

26import Options.Applicative

27import Options.Applicative

27

28

28import qualified Language.PureScript as P

29import qualified Language.PureScript as P

29import qualified Paths_purescript as Paths

30import qualified Paths_purescript as Paths

30import System.Exit (exitSuccess, exitFailure)

31import System.Exit (exitSuccess, exitFailure)

31−import System.IO (hPutStr, stderr)

32+import System.IO (hPutStrLn, stderr)

32−

33

33

34data PSCDocsOptions = PSCDocsOptions

34data PSCDocsOptions = PSCDocsOptions

35 { pscdIncludeHeir :: Bool

35 { pscdIncludeHeir :: Bool

36 , pscdInputFiles :: [FilePath]

36 , pscdInputFiles :: [FilePath]

37 }

37 }

38

38

39−

40docgen :: PSCDocsOptions -> IO ()

39docgen :: PSCDocsOptions -> IO ()

41docgen (PSCDocsOptions showHierarchy input) = do

40docgen (PSCDocsOptions showHierarchy input) = do

42 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

41 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

43 case e of

42 case e of

44 Left err -> do

43 Left err -> do

45− hPutStr stderr $ show err

44+ hPutStrLn stderr $ show err

46 exitFailure

45 exitFailure

47 Right ms -> do

46 Right ms -> do

48 putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)

47 putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)

@@ -62,10 +61,16 @@ spacer = tell [""]

62headerLevel :: Int -> String -> Docs

61headerLevel :: Int -> String -> Docs

63headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]

62headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]

64

63

64+withIndent :: Int -> Docs -> Docs

65+withIndent indent = censor (map (replicate indent ' ' ++ ))

66+

65atIndent :: Int -> String -> Docs

67atIndent :: Int -> String -> Docs

66atIndent indent text =

68atIndent indent text =

67 let ls = lines text in

69 let ls = lines text in

68− forM_ ls $ \l -> tell [replicate indent ' ' ++ l]

70+ withIndent indent (tell ls)

71+

72+ticks :: String -> String

73+ticks = ("`" ++) . (++ "`")

69

74

70renderModules :: Bool -> [P.Module] -> Docs

75renderModules :: Bool -> [P.Module] -> Docs

71renderModules showHierarchy ms = do

76renderModules showHierarchy ms = do

@@ -109,7 +114,9 @@ renderModule showHierarchy mdl@(P.Module moduleName _ exps) =

109

114

110renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs

115renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs

111renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do

116renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do

117+ traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)

118+ spacer

112− renderDeclaration 4 exps decl

119+ renderDeclaration exps decl

113 spacer

120 spacer

114

121

115renderTypeclassImage :: P.ModuleName -> Docs

122renderTypeclassImage :: P.ModuleName -> Docs

@@ -117,53 +124,81 @@ renderTypeclassImage name =

117 let name' = P.runModuleName name

124 let name' = P.runModuleName name

118 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]

125 in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]

119

126

127+getDeclarationTitle :: P.Declaration -> Maybe String

128+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)

129+getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)

130+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)

131+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)

132+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)

133+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)

134+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)

135+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

136+getDeclarationTitle _ = Nothing

137+

120−renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs

138+renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs

121−renderDeclaration n _ (P.TypeDeclaration ident ty) =

139+renderDeclaration _ (P.TypeDeclaration ident ty) =

122− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty

140+ atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty

123−renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =

141+renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =

124− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty

142+ atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty

125−renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do

143+renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do

126 let

144 let

127 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

145 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

128 typeName = prettyPrintType' typeApp

146 typeName = prettyPrintType' typeApp

129 exported = filter (P.isDctorExported name exps . fst) ctors

147 exported = filter (P.isDctorExported name exps . fst) ctors

130− atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")

148+ atIndent 4 $ show dtype ++ " " ++ typeName

131− forM_ exported $ \(ctor, tys) ->

149+ zipWithM_ (\isFirst (ctor, tys) ->

132− let ctorTy = foldr P.function typeApp tys

150+ atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))

133− in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy

151+ (True : repeat False) exported

134−renderDeclaration n _ (P.ExternDataDeclaration name kind) =

152+renderDeclaration _ (P.ExternDataDeclaration name kind) =

135− atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

153+ atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

136−renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do

154+renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do

137 let

155 let

138 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

156 typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

139− typeName = prettyPrintType' typeApp

157+ typeName = prettyPrintType' typeApp

140− atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

158+ atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

141−renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do

159+renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do

142 let impliesText = case implies of

160 let impliesText = case implies of

143 [] -> ""

161 [] -> ""

144 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

162 is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

145 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

163 classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

146 className = prettyPrintType' classApp

164 className = prettyPrintType' classApp

147− atIndent n $ "class " ++ impliesText ++ className ++ " where"

165+ atIndent 4 $ "class " ++ impliesText ++ className ++ " where"

148− mapM_ (renderDeclaration (n + 2) exps) ds

166+ mapM_ renderClassMember ds

167+ where

168+ renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d

169+ renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty

170+ renderClassMember _ = error "Invalid argument to renderClassMember."

149−renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do

171+renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do

150 let constraintsText = case constraints of

172 let constraintsText = case constraints of

151 [] -> ""

173 [] -> ""

152 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

174 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

153− atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

175+ atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

154−renderDeclaration n exps (P.PositionedDeclaration _ com d) = do

176+renderDeclaration exps (P.PositionedDeclaration _ com d) = do

155− renderComments n com

177+ renderComments com

156− spacer

157− renderDeclaration n exps d

178+ renderDeclaration exps d

158−renderDeclaration _ _ _ = return ()

179+renderDeclaration _ _ = return ()

159

180

160−renderComments :: Int -> [P.Comment] -> Docs

181+renderComments :: [P.Comment] -> Docs

161−renderComments n cs = mapM_ (atIndent n) ls

182+renderComments cs = do

162− where

163− ls = concatMap toLines cs

183+ let raw = concatMap toLines cs

184+

185+ if all hasPipe raw

186+ then atIndent 0 . unlines . map stripPipes $ raw

187+ else atIndent 4 $ unlines raw

164

188

189+ unless (null raw) spacer

190+ where

191+

165 toLines (P.LineComment s) = [s]

192 toLines (P.LineComment s) = [s]

166 toLines (P.BlockComment s) = lines s

193 toLines (P.BlockComment s) = lines s

194+

195+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

196+

197+ stripPipes = dropPipe . dropWhile (== ' ')

198+

199+ dropPipe ('|':' ':s) = s

200+ dropPipe ('|':s) = s

201+ dropPipe s = s

167

202

168toTypeVar :: (String, Maybe P.Kind) -> P.Type

203toTypeVar :: (String, Maybe P.Kind) -> P.Type

169toTypeVar (s, Nothing) = P.TypeVar s

204toTypeVar (s, Nothing) = P.TypeVar s

@@ -217,7 +252,7 @@ inputFile = strArgument $

217 <> help "The input .purs file(s)"

252 <> help "The input .purs file(s)"

218

253

219includeHeirarcy :: Parser Bool

254includeHeirarcy :: Parser Bool

220−includeHeirarcy = switch $

255+includeHeirarcy = switch $

221 long "hierarchy-images"

256 long "hierarchy-images"

222 <> help "Include markdown for type class hierarchy images in the output."

257 <> help "Include markdown for type class hierarchy images in the output."

223

258

@@ -232,6 +267,6 @@ main = execParser opts >>= docgen

232 infoModList = fullDesc <> headerInfo <> footerInfo

267 infoModList = fullDesc <> headerInfo <> footerInfo

233 headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"

268 headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"

234 footerInfo = footer $ "psc-docs " ++ showVersion Paths.version

269 footerInfo = footer $ "psc-docs " ++ showVersion Paths.version

235−

270+

236 version :: Parser (a -> a)

271 version :: Parser (a -> a)

237 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

272 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

psc-make/Main.hs+27−20

@@ -18,8 +18,10 @@ module Main where

18

18

19import Control.Applicative

19import Control.Applicative

20import Control.Monad.Error

20import Control.Monad.Error

21+import Control.Monad.Reader

21

22

22import Data.Version (showVersion)

23import Data.Version (showVersion)

24+import Data.Traversable (traverse)

23

25

24import Options.Applicative as Opts

26import Options.Applicative as Opts

25

27

@@ -50,20 +52,19 @@ readInput InputOptions{..} = do

50 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

52 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

51 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

53 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

52

54

55+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }

53−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)

56+ deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))

54

57

55−runMake :: Make a -> IO (Either String a)

58+runMake :: P.Options P.Make -> Make a -> IO (Either String a)

56−runMake = runErrorT . unMake

59+runMake opts = runErrorT . flip runReaderT opts . unMake

57

60

58makeIO :: IO a -> Make a

61makeIO :: IO a -> Make a

59−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError

62+makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError

60

63

61instance P.MonadMake Make where

64instance P.MonadMake Make where

62 getTimestamp path = makeIO $ do

65 getTimestamp path = makeIO $ do

63 exists <- doesFileExist path

66 exists <- doesFileExist path

64− case exists of

65− True -> Just <$> getModificationTime path

67+ traverse (const $ getModificationTime path) $ guard exists

66− False -> return Nothing

67 readTextFile path = makeIO $ do

68 readTextFile path = makeIO $ do

68 putStrLn $ "Reading " ++ path

69 putStrLn $ "Reading " ++ path

69 readFile path

70 readFile path

@@ -71,7 +72,6 @@ instance P.MonadMake Make where

71 mkdirp path

72 mkdirp path

72 putStrLn $ "Writing " ++ path

73 putStrLn $ "Writing " ++ path

73 writeFile path text

74 writeFile path text

74− liftError = either throwError return

75 progress = makeIO . putStrLn

75 progress = makeIO . putStrLn

76

76

77compile :: PSCMakeOptions -> IO ()

77compile :: PSCMakeOptions -> IO ()

@@ -82,7 +82,7 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do

82 print err

82 print err

83 exitFailure

83 exitFailure

84 Right ms -> do

84 Right ms -> do

85− e <- runMake $ P.make outputDir opts ms prefix

85+ e <- runMake opts $ P.make outputDir ms prefix

86 case e of

86 case e of

87 Left err -> do

87 Left err -> do

88 putStrLn err

88 putStrLn err

@@ -111,12 +111,12 @@ outputDirectory = strOption $

111 <> help "The output directory"

111 <> help "The output directory"

112

112

113noTco :: Parser Bool

113noTco :: Parser Bool

114−noTco = switch $

114+noTco = switch $

115 long "no-tco"

115 long "no-tco"

116 <> help "Disable tail call optimizations"

116 <> help "Disable tail call optimizations"

117

117

118noPrelude :: Parser Bool

118noPrelude :: Parser Bool

119−noPrelude = switch $

119+noPrelude = switch $

120 long "no-prelude"

120 long "no-prelude"

121 <> help "Omit the Prelude"

121 <> help "Omit the Prelude"

122

122

@@ -127,35 +127,42 @@ noMagicDo = switch $

127

127

128noOpts :: Parser Bool

128noOpts :: Parser Bool

129noOpts = switch $

129noOpts = switch $

130− long "verbose-errors"

130+ long "no-opts"

131 <> help "Skip the optimization phase."

131 <> help "Skip the optimization phase."

132

132

133+comments :: Parser Bool

134+comments = switch $

135+ short 'c'

136+ <> long "comments"

137+ <> help "Include comments in the generated code."

138+

133verboseErrors :: Parser Bool

139verboseErrors :: Parser Bool

134verboseErrors = switch $

140verboseErrors = switch $

135 short 'v'

141 short 'v'

136− <> long "no-opts"

142+ <> long "verbose-errors"

137 <> help "Display verbose error messages"

143 <> help "Display verbose error messages"

138

144

139noPrefix :: Parser Bool

145noPrefix :: Parser Bool

140−noPrefix = switch $

146+noPrefix = switch $

141 short 'p'

147 short 'p'

142 <> long "no-prefix"

148 <> long "no-prefix"

143 <> help "Do not include comment header"

149 <> help "Do not include comment header"

144

150

145

151

146options :: Parser (P.Options P.Make)

152options :: Parser (P.Options P.Make)

147−options = P.Options <$> noPrelude

153+options = P.Options <$> noPrelude

148− <*> noTco

154+ <*> noTco

149 <*> noMagicDo

155 <*> noMagicDo

150 <*> pure Nothing

156 <*> pure Nothing

151 <*> noOpts

157 <*> noOpts

158+ <*> comments

152 <*> verboseErrors

159 <*> verboseErrors

153 <*> pure P.MakeOptions

160 <*> pure P.MakeOptions

154

161

155pscMakeOptions :: Parser PSCMakeOptions

162pscMakeOptions :: Parser PSCMakeOptions

156−pscMakeOptions = PSCMakeOptions <$> many inputFile

163+pscMakeOptions = PSCMakeOptions <$> many inputFile

157− <*> outputDirectory

164+ <*> outputDirectory

158− <*> options

165+ <*> options

159 <*> (not <$> noPrefix)

166 <*> (not <$> noPrefix)

160

167

161main :: IO ()

168main :: IO ()

@@ -165,6 +172,6 @@ main = execParser opts >>= compile

165 infoModList = fullDesc <> headerInfo <> footerInfo

172 infoModList = fullDesc <> headerInfo <> footerInfo

166 headerInfo = header "psc-make - Compiles PureScript to Javascript"

173 headerInfo = header "psc-make - Compiles PureScript to Javascript"

167 footerInfo = footer $ "psc-make " ++ showVersion Paths.version

174 footerInfo = footer $ "psc-make " ++ showVersion Paths.version

168−

175+

169 version :: Parser (a -> a)

176 version :: Parser (a -> a)

170 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

177 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

psc/Main.hs+22−14

@@ -18,6 +18,7 @@ module Main where

18

18

19import Control.Applicative

19import Control.Applicative

20import Control.Monad.Error

20import Control.Monad.Error

21+import Control.Monad.Reader

21

22

22import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

23import Data.Version (showVersion)

24import Data.Version (showVersion)

@@ -26,7 +27,7 @@ import Options.Applicative as Opts

26import System.Directory (createDirectoryIfMissing)

27import System.Directory (createDirectoryIfMissing)

27import System.FilePath (takeDirectory)

28import System.FilePath (takeDirectory)

28import System.Exit (exitSuccess, exitFailure)

29import System.Exit (exitSuccess, exitFailure)

29−import System.IO (hPutStr, hPutStrLn, stderr)

30+import System.IO (hPutStrLn, stderr)

30

31

31import qualified Language.PureScript as P

32import qualified Language.PureScript as P

32import qualified Paths_purescript as Paths

33import qualified Paths_purescript as Paths

@@ -58,10 +59,10 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do

58 modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

59 modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

59 case modules of

60 case modules of

60 Left err -> do

61 Left err -> do

61− hPutStr stderr $ show err

62+ hPutStrLn stderr $ show err

62 exitFailure

63 exitFailure

63 Right ms -> do

64 Right ms -> do

64− case P.compile opts (map snd ms) prefix of

65+ case P.compile (map snd ms) prefix `runReaderT` opts of

65 Left err -> do

66 Left err -> do

66 hPutStrLn stderr err

67 hPutStrLn stderr err

67 exitFailure

68 exitFailure

@@ -115,28 +116,34 @@ runMain = optional $ noArgs <|> withArgs

115 where

116 where

116 defaultVal = "Main"

117 defaultVal = "Main"

117 noArgs = flag' defaultVal (long "main")

118 noArgs = flag' defaultVal (long "main")

118− withArgs = strOption $

119+ withArgs = strOption $

119 long "main"

120 long "main"

120 <> help (concat [

121 <> help (concat [

121 "Generate code to run the main method in the specified module. ",

122 "Generate code to run the main method in the specified module. ",

122 "(no argument: \"", defaultVal, "\")"

123 "(no argument: \"", defaultVal, "\")"

123 ])

124 ])

124−

125+

125noMagicDo :: Parser Bool

126noMagicDo :: Parser Bool

126noMagicDo = switch $

127noMagicDo = switch $

127 long "no-magic-do"

128 long "no-magic-do"

128 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."

129 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."

129−

130+

130noTco :: Parser Bool

131noTco :: Parser Bool

131−noTco = switch $

132+noTco = switch $

132 long "no-tco"

133 long "no-tco"

133 <> help "Disable tail call optimizations"

134 <> help "Disable tail call optimizations"

134

135

135noPrelude :: Parser Bool

136noPrelude :: Parser Bool

136−noPrelude = switch $

137+noPrelude = switch $

137 long "no-prelude"

138 long "no-prelude"

138 <> help "Omit the Prelude"

139 <> help "Omit the Prelude"

139

140

141+comments :: Parser Bool

142+comments = switch $

143+ short 'c'

144+ <> long "comments"

145+ <> help "Include comments in the generated code."

146+

140useStdIn :: Parser Bool

147useStdIn :: Parser Bool

141useStdIn = switch $

148useStdIn = switch $

142 short 's'

149 short 's'

@@ -161,22 +168,23 @@ externsFile = optional . strOption $

161 <> help "The output .e.purs file"

168 <> help "The output .e.purs file"

162

169

163noPrefix :: Parser Bool

170noPrefix :: Parser Bool

164−noPrefix = switch $

171+noPrefix = switch $

165 short 'p'

172 short 'p'

166 <> long "no-prefix"

173 <> long "no-prefix"

167 <> help "Do not include comment header"

174 <> help "Do not include comment header"

168

175

169options :: Parser (P.Options P.Compile)

176options :: Parser (P.Options P.Compile)

170−options = P.Options <$> noPrelude

177+options = P.Options <$> noPrelude

171− <*> noTco

178+ <*> noTco

172 <*> noMagicDo

179 <*> noMagicDo

173 <*> runMain

180 <*> runMain

174 <*> noOpts

181 <*> noOpts

175 <*> verboseErrors

182 <*> verboseErrors

183+ <*> comments

176 <*> additionalOptions

184 <*> additionalOptions

177 where

185 where

178− additionalOptions =

186+ additionalOptions =

179− P.CompileOptions <$> browserNamespace

187+ P.CompileOptions <$> browserNamespace

180 <*> many dceModule

188 <*> many dceModule

181 <*> many codeGenModule

189 <*> many codeGenModule

182

190

@@ -195,7 +203,7 @@ main = execParser opts >>= compile

195 infoModList = fullDesc <> headerInfo <> footerInfo

203 infoModList = fullDesc <> headerInfo <> footerInfo

196 headerInfo = header "psc - Compiles PureScript to Javascript"

204 headerInfo = header "psc - Compiles PureScript to Javascript"

197 footerInfo = footer $ "psc " ++ showVersion Paths.version

205 footerInfo = footer $ "psc " ++ showVersion Paths.version

198−

206+

199 version :: Parser (a -> a)

207 version :: Parser (a -> a)

200 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

208 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

201

209

psci/Commands.hs+1−1

@@ -52,7 +52,7 @@ data Command

52 -- |

52 -- |

53 -- Binds a value to a name

53 -- Binds a value to a name

54 --

54 --

55− | Let (Expr -> Expr)

55+ | Let [Declaration]

56 -- |

56 -- |

57 -- Find the type of an expression

57 -- Find the type of an expression

58 --

58 --

psci/Main.hs+40−30

@@ -28,7 +28,7 @@ import qualified Data.Map as M

28import Control.Applicative

28import Control.Applicative

29import Control.Monad

29import Control.Monad

30import Control.Monad.Error (ErrorT(..), MonadError)

30import Control.Monad.Error (ErrorT(..), MonadError)

31−import Control.Monad.Error.Class (MonadError(..))

31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

32import Control.Monad.Trans.Class

32import Control.Monad.Trans.Class

33import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

33import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

34import Control.Monad.Trans.State.Strict

34import Control.Monad.Trans.State.Strict

@@ -69,7 +69,7 @@ data PSCiState = PSCiState

69 { psciImportedFilenames :: [FilePath]

69 { psciImportedFilenames :: [FilePath]

70 , psciImportedModuleNames :: [P.ModuleName]

70 , psciImportedModuleNames :: [P.ModuleName]

71 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]

71 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]

72− , psciLetBindings :: [P.Expr -> P.Expr]

72+ , psciLetBindings :: [P.Declaration]

73 }

73 }

74

74

75-- State helpers

75-- State helpers

@@ -95,8 +95,8 @@ updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modu

95-- |

95-- |

96-- Updates the state to have more let bindings.

96-- Updates the state to have more let bindings.

97--

97--

98−updateLets :: (P.Expr -> P.Expr) -> PSCiState -> PSCiState

98+updateLets :: [P.Declaration] -> PSCiState -> PSCiState

99−updateLets name st = st { psciLetBindings = name : psciLetBindings st }

99+updateLets ds st = st { psciLetBindings = ds ++ psciLetBindings st }

100

100

101-- File helpers

101-- File helpers

102-- |

102-- |

@@ -141,6 +141,16 @@ loadAllModules files = do

141 return (Right filename, content)

141 return (Right filename, content)

142 return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent

142 return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent

143

143

144+-- |

145+-- Load all modules, updating the application state

146+--

147+loadAllImportedModules :: PSCI ()

148+loadAllImportedModules = do

149+ files <- PSCI . lift $ fmap psciImportedFilenames get

150+ modulesOrFirstError <- psciIO $ loadAllModules files

151+ case modulesOrFirstError of

152+ Left err -> psciIO $ print err

153+ Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }

144

154

145-- |

155-- |

146-- Expands tilde in path.

156-- Expands tilde in path.

@@ -304,7 +314,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions

304-- | Compilation options.

314-- | Compilation options.

305--

315--

306options :: P.Options P.Make

316options :: P.Options P.Make

307−options = P.Options False False False Nothing False False P.MakeOptions

317+options = P.Options False False False Nothing False False False P.MakeOptions

308

318

309-- |

319-- |

310-- PSCI monad

320-- PSCI monad

@@ -312,27 +322,25 @@ options = P.Options False False False Nothing False False P.MakeOptions

312newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

322newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

313

323

314psciIO :: IO a -> PSCI a

324psciIO :: IO a -> PSCI a

315−psciIO io = PSCI (lift (lift io))

325+psciIO io = PSCI . lift $ lift io

316

326

327+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }

317−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)

328+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))

318

329

319runMake :: Make a -> IO (Either String a)

330runMake :: Make a -> IO (Either String a)

320−runMake = runErrorT . unMake

331+runMake = runErrorT . flip runReaderT options . unMake

321

332

322makeIO :: IO a -> Make a

333makeIO :: IO a -> Make a

323−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError

334+makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError

324

335

325instance P.MonadMake Make where

336instance P.MonadMake Make where

326 getTimestamp path = makeIO $ do

337 getTimestamp path = makeIO $ do

327 exists <- doesFileExist path

338 exists <- doesFileExist path

328− if exists

329− then Just <$> getModificationTime path

339+ traverse (const $ getModificationTime path) $ guard exists

330− else return Nothing

331 readTextFile path = makeIO $ readFile path

340 readTextFile path = makeIO $ readFile path

332 writeTextFile path text = makeIO $ do

341 writeTextFile path text = makeIO $ do

333 mkdirp path

342 mkdirp path

334 writeFile path text

343 writeFile path text

335− liftError = either throwError return

336 progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s

344 progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s

337

345

338mkdirp :: FilePath -> IO ()

346mkdirp :: FilePath -> IO ()

@@ -348,13 +356,13 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB

348 importDecl m = P.ImportDeclaration m P.Unqualified Nothing

356 importDecl m = P.ImportDeclaration m P.Unqualified Nothing

349 traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]

357 traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]

350 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

358 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

351− itValue = foldl (\x f -> f x) val lets

352 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

359 mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

353− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue

360+ itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val

354 mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue

361 mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue

355 decls = if exec then [itDecl, mainDecl] else [itDecl]

362 decls = if exec then [itDecl, mainDecl] else [itDecl]

356 in

363 in

357− P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing

364+ P.Module moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

365+

358

366

359-- |

367-- |

360-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

368-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

@@ -392,7 +400,7 @@ handleDeclaration :: P.Expr -> PSCI ()

392handleDeclaration val = do

400handleDeclaration val = do

393 st <- PSCI $ lift get

401 st <- PSCI $ lift get

394 let m = createTemporaryModule True st val

402 let m = createTemporaryModule True st val

395− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

403+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

396 case e of

404 case e of

397 Left err -> PSCI $ outputStrLn err

405 Left err -> PSCI $ outputStrLn err

398 Right _ -> do

406 Right _ -> do

@@ -408,12 +416,12 @@ handleDeclaration val = do

408-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,

416-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,

409-- restore the pre-let environment.

417-- restore the pre-let environment.

410--

418--

411−handleLet :: (P.Expr -> P.Expr) -> PSCI ()

419+handleLet :: [P.Declaration] -> PSCI ()

412−handleLet l = do

420+handleLet ds = do

413 st <- PSCI $ lift get

421 st <- PSCI $ lift get

414− let st' = updateLets l st

422+ let st' = updateLets ds st

415 let m = createTemporaryModule False st' (P.ObjectLiteral [])

423 let m = createTemporaryModule False st' (P.ObjectLiteral [])

416− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

424+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

417 case e of

425 case e of

418 Left err -> PSCI $ outputStrLn err

426 Left err -> PSCI $ outputStrLn err

419 Right _ -> PSCI $ lift (put st')

427 Right _ -> PSCI $ lift (put st')

@@ -446,7 +454,7 @@ handleImport :: P.ModuleName -> PSCI ()

446handleImport moduleName = do

454handleImport moduleName = do

447 st <- updateImports moduleName <$> PSCI (lift get)

455 st <- updateImports moduleName <$> PSCI (lift get)

448 let m = createTemporaryModuleForImports st

456 let m = createTemporaryModuleForImports st

449− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

457+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

450 case e of

458 case e of

451 Left err -> PSCI $ outputStrLn err

459 Left err -> PSCI $ outputStrLn err

452 Right _ -> do

460 Right _ -> do

@@ -460,7 +468,7 @@ handleTypeOf :: P.Expr -> PSCI ()

460handleTypeOf val = do

468handleTypeOf val = do

461 st <- PSCI $ lift get

469 st <- PSCI $ lift get

462 let m = createTemporaryModule False st val

470 let m = createTemporaryModule False st val

463− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

471+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

464 case e of

472 case e of

465 Left err -> PSCI $ outputStrLn err

473 Left err -> PSCI $ outputStrLn err

466 Right env' ->

474 Right env' ->

@@ -494,7 +502,7 @@ handleBrowse :: P.ModuleName -> PSCI ()

494handleBrowse moduleName = do

502handleBrowse moduleName = do

495 st <- PSCI $ lift get

503 st <- PSCI $ lift get

496 let loadedModules = psciLoadedModules st

504 let loadedModules = psciLoadedModules st

497− env <- psciIO . runMake $ P.make modulesDir options loadedModules []

505+ env <- psciIO . runMake $ P.make modulesDir loadedModules []

498 case env of

506 case env of

499 Left err -> PSCI $ outputStrLn err

507 Left err -> PSCI $ outputStrLn err

500 Right env' ->

508 Right env' ->

@@ -510,7 +518,7 @@ handleKindOf typ = do

510 st <- PSCI $ lift get

518 st <- PSCI $ lift get

511 let m = createTemporaryModuleForKind st typ

519 let m = createTemporaryModuleForKind st typ

512 mName = P.ModuleName [P.ProperName "$PSCI"]

520 mName = P.ModuleName [P.ProperName "$PSCI"]

513− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

521+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

514 case e of

522 case e of

515 Left err -> PSCI $ outputStrLn err

523 Left err -> PSCI $ outputStrLn err

516 Right env' ->

524 Right env' ->

@@ -561,10 +569,12 @@ handleCommand (LoadFile filePath) = do

561 PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

569 PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

562handleCommand Reset = do

570handleCommand Reset = do

563 files <- psciImportedFilenames <$> PSCI (lift get)

571 files <- psciImportedFilenames <$> PSCI (lift get)

564− modulesOrFirstError <- psciIO $ loadAllModules files

572+ PSCI . lift . modify $ \st -> st

565− case modulesOrFirstError of

573+ { psciImportedFilenames = files

566− Left err -> psciIO $ print err >> exitFailure

574+ , psciImportedModuleNames = defaultImports

567− Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])

575+ , psciLetBindings = []

576+ }

577+ loadAllImportedModules

568handleCommand (TypeOf val) = handleTypeOf val

578handleCommand (TypeOf val) = handleTypeOf val

569handleCommand (KindOf typ) = handleKindOf typ

579handleCommand (KindOf typ) = handleKindOf typ

570handleCommand (Browse moduleName) = handleBrowse moduleName

580handleCommand (Browse moduleName) = handleBrowse moduleName

@@ -609,7 +619,7 @@ loop (PSCiOptions singleLineMode files) = do

609 Left err -> outputStrLn err >> go

619 Left err -> outputStrLn err >> go

610 Right Nothing -> go

620 Right Nothing -> go

611 Right (Just Quit) -> outputStrLn quitMessage

621 Right (Just Quit) -> outputStrLn quitMessage

612− Right (Just c') -> runPSCI (handleCommand c') >> go

622+ Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go

613

623

614singleLineFlag :: Parser Bool

624singleLineFlag :: Parser Bool

615singleLineFlag = switch $

625singleLineFlag = switch $

psci/Parser.hs+5−5

@@ -34,8 +34,8 @@ import qualified Language.PureScript.Parser.Common as C (mark, same)

34-- Parses PSCI metacommands or expressions input from the user.

34-- Parses PSCI metacommands or expressions input from the user.

35--

35--

36parseCommand :: String -> Either String Command

36parseCommand :: String -> Either String Command

37−parseCommand cmdString =

37+parseCommand cmdString =

38− case splitCommand cmdString of

38+ case splitCommand cmdString of

39 Just ('?', _) -> return Help

39 Just ('?', _) -> return Help

40 Just ('q', _) -> return Quit

40 Just ('q', _) -> return Quit

41 Just ('r', _) -> return Reset

41 Just ('r', _) -> return Reset

@@ -52,7 +52,7 @@ parseCommand cmdString =

52 parseRest p s = either (Left . show) Right $ do

52 parseRest p s = either (Left . show) Right $ do

53 ts <- P.lex "" s

53 ts <- P.lex "" s

54 P.runTokenParser "" (p <* eof) ts

54 P.runTokenParser "" (p <* eof) ts

55−

55+

56 trimEnd :: String -> String

56 trimEnd :: String -> String

57 trimEnd = reverse . dropWhile isSpace . reverse

57 trimEnd = reverse . dropWhile isSpace . reverse

58

58

@@ -68,7 +68,7 @@ parseCommand cmdString =

68 --

68 --

69 psciExpression :: P.TokenParser Command

69 psciExpression :: P.TokenParser Command

70 psciExpression = Expression <$> P.parseValue

70 psciExpression = Expression <$> P.parseValue

71−

71+

72 -- |

72 -- |

73 -- PSCI version of @let@.

73 -- PSCI version of @let@.

74 -- This is essentially let from do-notation.

74 -- This is essentially let from do-notation.

@@ -76,7 +76,7 @@ parseCommand cmdString =

76 -- we actually want the normal @let@.

76 -- we actually want the normal @let@.

77 --

77 --

78 psciLet :: P.TokenParser Command

78 psciLet :: P.TokenParser Command

79− psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> manyDecls))

79+ psciLet = Let <$> (P.reserved "let" *> P.indented *> manyDecls)

80 where

80 where

81 manyDecls :: P.TokenParser [P.Declaration]

81 manyDecls :: P.TokenParser [P.Declaration]

82 manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))

82 manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))

purescript.cabal+4−3

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

1name: purescript

1name: purescript

2−version: 0.6.4

2+version: 0.6.7.1

3cabal-version: >=1.8

3cabal-version: >=1.8

4build-type: Simple

4build-type: Simple

5license: MIT

5license: MIT

@@ -93,6 +93,7 @@ library

93 Language.PureScript.Sugar.CaseDeclarations

93 Language.PureScript.Sugar.CaseDeclarations

94 Language.PureScript.Sugar.DoNotation

94 Language.PureScript.Sugar.DoNotation

95 Language.PureScript.Sugar.Names

95 Language.PureScript.Sugar.Names

96+ Language.PureScript.Sugar.ObjectWildcards

96 Language.PureScript.Sugar.Operators

97 Language.PureScript.Sugar.Operators

97 Language.PureScript.Sugar.TypeClasses

98 Language.PureScript.Sugar.TypeClasses

98 Language.PureScript.Sugar.TypeDeclarations

99 Language.PureScript.Sugar.TypeDeclarations

@@ -150,7 +151,7 @@ executable psci

150 ghc-options: -Wall -fno-warn-warnings-deprecations -O2

151 ghc-options: -Wall -fno-warn-warnings-deprecations -O2

151

152

152executable psc-docs

153executable psc-docs

153− build-depends: base >=4 && <5, purescript -any,

154+ build-depends: base >=4 && <5, purescript -any,

154 optparse-applicative >= 0.10.0, process -any, mtl -any

155 optparse-applicative >= 0.10.0, process -any, mtl -any

155 main-is: Main.hs

156 main-is: Main.hs

156 buildable: True

157 buildable: True

@@ -158,7 +159,7 @@ executable psc-docs

158 other-modules:

159 other-modules:

159 ghc-options: -Wall -fno-warn-warnings-deprecations -O2

160 ghc-options: -Wall -fno-warn-warnings-deprecations -O2

160

161

161−executable hierarchy

162+executable psc-hierarchy

162 build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,

163 build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,

163 process -any, mtl -any, parsec -any, filepath -any, directory -any

164 process -any, mtl -any, parsec -any, filepath -any, directory -any

164 main-is: Main.hs

165 main-is: Main.hs

src/Language/PureScript.hs+40−35

@@ -13,7 +13,7 @@

13--

13--

14-----------------------------------------------------------------------------

14-----------------------------------------------------------------------------

15

15

16−{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}

16+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}

17

17

18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where

18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where

19

19

@@ -22,6 +22,7 @@ import Data.Function (on)

22import Data.List (sortBy, groupBy, intercalate)

22import Data.List (sortBy, groupBy, intercalate)

23import Data.Maybe (fromMaybe)

23import Data.Maybe (fromMaybe)

24import Data.Time.Clock

24import Data.Time.Clock

25+import qualified Data.Traversable as T (traverse)

25import qualified Data.ByteString.UTF8 as BU

26import qualified Data.ByteString.UTF8 as BU

26import qualified Data.Map as M

27import qualified Data.Map as M

27import qualified Data.Set as S

28import qualified Data.Set as S

@@ -29,6 +30,7 @@ import qualified Data.Set as S

29import Control.Applicative

30import Control.Applicative

30import Control.Arrow ((&&&))

31import Control.Arrow ((&&&))

31import Control.Monad.Error

32import Control.Monad.Error

33+import Control.Monad.Reader

32

34

33import System.FilePath ((</>))

35import System.FilePath ((</>))

34

36

@@ -71,42 +73,47 @@ import qualified Language.PureScript.Constants as C

71--

73--

72-- * Pretty-print the generated Javascript

74-- * Pretty-print the generated Javascript

73--

75--

76+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

74−compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

77+ => [Module] -> [String] -> m (String, String, Environment)

75compile = compile' initEnvironment

78compile = compile' initEnvironment

76

79

80+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

77−compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

81+ => Environment -> [Module] -> [String] -> m (String, String, Environment)

78−compile' env opts ms prefix = do

82+compile' env ms prefix = do

83+ noPrelude <- asks optionsNoPrelude

84+ additional <- asks optionsAdditional

85+ mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

79− (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms

86+ (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

80 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

87 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

81− (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

88+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

82 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

89 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

83 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

90 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

84− let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)

91+ let entryPoints = moduleNameFromString `map` entryPointModules additional

85 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

92 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

86 let renamed = renameInModules elim

93 let renamed = renameInModules elim

87− let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)

94+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

88 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

95 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

89− let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen

96+ js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)

90 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

97 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

91− js' <- generateMain env' opts js

98+ js' <- generateMain env' js

92 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

99 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

93 return (pjs, exts, env')

100 return (pjs, exts, env')

94− where

95− mainModuleIdent = moduleNameFromString <$> optionsMain opts

96

101

97−generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]

102+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]

98−generateMain env opts js =

103+generateMain env js = do

104+ main <- asks optionsMain

105+ additional <- asks optionsAdditional

99− case moduleNameFromString <$> optionsMain opts of

106+ case moduleNameFromString <$> main of

100 Just mmi -> do

107 Just mmi -> do

101 when ((mmi, Ident C.main) `M.notMember` names env) $

108 when ((mmi, Ident C.main) `M.notMember` names env) $

102− Left $ show mmi ++ "." ++ C.main ++ " is undefined"

109+ throwError $ show mmi ++ "." ++ C.main ++ " is undefined"

103− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]

110+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]

104 _ -> return js

111 _ -> return js

105

112

106-- |

113-- |

107-- A type class which collects the IO actions we need to be able to run in "make" mode

114-- A type class which collects the IO actions we need to be able to run in "make" mode

108--

115--

109−class MonadMake m where

116+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where

110 -- |

117 -- |

111 -- Get a file timestamp

118 -- Get a file timestamp

112 --

119 --

@@ -122,11 +129,6 @@ class MonadMake m where

122 --

129 --

123 writeTextFile :: FilePath -> String -> m ()

130 writeTextFile :: FilePath -> String -> m ()

124

131

125− -- |

126− -- Report an error

127− --

128− liftError :: Either String a -> m a

129−

130 -- |

132 -- |

131 -- Respond to a progress update

133 -- Respond to a progress update

132 --

134 --

@@ -152,11 +154,13 @@ traverseEither f (Right y) = Right <$> f y

152-- If timestamps have not changed, the externs file can be used to provide the module's types without

154-- If timestamps have not changed, the externs file can be used to provide the module's types without

153-- having to typecheck the module again.

155-- having to typecheck the module again.

154--

156--

157+make :: (Functor m, Applicative m, Monad m, MonadMake m)

155−make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

158+ => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

156−make outputDir opts ms prefix = do

159+make outputDir ms prefix = do

160+ noPrelude <- asks optionsNoPrelude

157 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

161 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

158

162

159− (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms

163+ (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

160

164

161 toRebuild <- foldM (\s (Module moduleName' _ _) -> do

165 toRebuild <- foldM (\s (Module moduleName' _ _) -> do

162 let filePath = runModuleName moduleName'

166 let filePath = runModuleName moduleName'

@@ -176,15 +180,16 @@ make outputDir opts ms prefix = do

176

180

177 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

181 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

178

182

179− (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

183+ (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

180

184

181− evalSupplyT nextVar (go initEnvironment desugared)

185+ evalSupplyT nextVar $ go initEnvironment desugared

182

186

183 where

187 where

188+ go :: (Functor m, Applicative m, Monad m, MonadMake m)

184− go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment

189+ => Environment -> [(Bool, Module)] -> SupplyT m Environment

185 go env [] = return env

190 go env [] = return env

186 go env ((False, m) : ms') = do

191 go env ((False, m) : ms') = do

187− (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m

192+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

188

193

189 go env' ms'

194 go env' ms'

190 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

195 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

@@ -194,15 +199,15 @@ make outputDir opts ms prefix = do

194

199

195 lift . progress $ "Compiling " ++ runModuleName moduleName'

200 lift . progress $ "Compiling " ++ runModuleName moduleName'

196

201

197− (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m

202+ (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

198

203

199− regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

204+ regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

200

205

201 let mod' = Module moduleName' regrouped exps

206 let mod' = Module moduleName' regrouped exps

202 let corefn = CoreFn.moduleToCoreFn env' mod'

207 let corefn = CoreFn.moduleToCoreFn env' mod'

203 let [renamed] = renameInModules [corefn]

208 let [renamed] = renameInModules [corefn]

204

209

205− pjs <- prettyPrintJS <$> moduleToJs opts renamed

210+ pjs <- prettyPrintJS <$> moduleToJs renamed

206 let js = unlines $ map ("// " ++) prefix ++ [pjs]

211 let js = unlines $ map ("// " ++) prefix ++ [pjs]

207 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

212 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

208

213

@@ -220,10 +225,10 @@ make outputDir opts ms prefix = do

220 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do

225 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do

221 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

226 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

222 externs <- readTextFile externsFile

227 externs <- readTextFile externsFile

223− externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]

228+ externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]

224 case externsModules of

229 case externsModules of

225 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

230 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

226− _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"

231+ _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"

227

232

228reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

233reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

229reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

234reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

src/Language/PureScript/AST/Declarations.hs+21−1

@@ -305,13 +305,18 @@ data Expr

305 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

305 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

306 -- will be removed.

306 -- will be removed.

307 --

307 --

308− | BinaryNoParens (Qualified Ident) Expr Expr

308+ | BinaryNoParens Expr Expr Expr

309 -- |

309 -- |

310 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

310 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

311 -- will be removed.

311 -- will be removed.

312 --

312 --

313 | Parens Expr

313 | Parens Expr

314 -- |

314 -- |

315+ -- Operator section. This will be removed during desugaring and replaced with a partially applied

316+ -- operator or lambda to flip the arguments.

317+ --

318+ | OperatorSection Expr (Either Expr Expr)

319+ -- |

315 -- An array literal

320 -- An array literal

316 --

321 --

317 | ArrayLiteral [Expr]

322 | ArrayLiteral [Expr]

@@ -320,6 +325,16 @@ data Expr

320 --

325 --

321 | ObjectLiteral [(String, Expr)]

326 | ObjectLiteral [(String, Expr)]

322 -- |

327 -- |

328+ -- An object constructor (object literal with underscores). This will be removed during

329+ -- desugaring and expanded into a lambda that returns an object literal.

330+ --

331+ | ObjectConstructor [(String, Maybe Expr)]

332+ -- |

333+ -- An object property getter (e.g. `_.x`). This will be removed during

334+ -- desugaring and expanded into a lambda that reads a property from an object.

335+ --

336+ | ObjectGetter String

337+ -- |

323 -- An record property accessor expression

338 -- An record property accessor expression

324 --

339 --

325 | Accessor String Expr

340 | Accessor String Expr

@@ -328,6 +343,11 @@ data Expr

328 --

343 --

329 | ObjectUpdate Expr [(String, Expr)]

344 | ObjectUpdate Expr [(String, Expr)]

330 -- |

345 -- |

346+ -- Partial record updater. This will be removed during desugaring and

347+ -- expanded into a lambda that returns an object update.

348+ --

349+ | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]

350+ -- |

331 -- Function introduction

351 -- Function introduction

332 --

352 --

333 | Abs (Either Ident Binder) Expr

353 | Abs (Either Ident Binder) Expr

src/Language/PureScript/AST/SourcePos.hs+2−2

@@ -48,6 +48,6 @@ data SourceSpan = SourceSpan

48 --

48 --

49 , spanEnd :: SourcePos

49 , spanEnd :: SourcePos

50 } deriving (D.Data, D.Typeable)

50 } deriving (D.Data, D.Typeable)

51−

51+

52instance Show SourceSpan where

52instance Show SourceSpan where

53− show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

53+ show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

src/Language/PureScript/AST/Traversals.hs+32−8

@@ -15,10 +15,11 @@

15module Language.PureScript.AST.Traversals where

15module Language.PureScript.AST.Traversals where

16

16

17import Data.Monoid (Monoid(..), mconcat)

17import Data.Monoid (Monoid(..), mconcat)

18+import Data.Maybe (mapMaybe)

18

19

19import Control.Applicative

20import Control.Applicative

20import Control.Monad

21import Control.Monad

21−import Control.Arrow ((***), (+++))

22+import Control.Arrow ((***), (+++), second)

22

23

23import Language.PureScript.AST.Binders

24import Language.PureScript.AST.Binders

24import Language.PureScript.AST.Declarations

25import Language.PureScript.AST.Declarations

@@ -42,13 +43,17 @@ everywhereOnValues f g h = (f', g', h')

42

43

43 g' :: Expr -> Expr

44 g' :: Expr -> Expr

44 g' (UnaryMinus v) = g (UnaryMinus (g' v))

45 g' (UnaryMinus v) = g (UnaryMinus (g' v))

45− g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

46+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))

46 g' (Parens v) = g (Parens (g' v))

47 g' (Parens v) = g (Parens (g' v))

48+ g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))

49+ g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))

47 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

50 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

48 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

51 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

52+ g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))

49 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

53 g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

50 g' (Accessor prop v) = g (Accessor prop (g' v))

54 g' (Accessor prop v) = g (Accessor prop (g' v))

51 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

55 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

56+ g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))

52 g' (Abs name v) = g (Abs name (g' v))

57 g' (Abs name v) = g (Abs name (g' v))

53 g' (App v1 v2) = g (App (g' v1) (g' v2))

58 g' (App v1 v2) = g (App (g' v1) (g' v2))

54 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

59 g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))

@@ -80,7 +85,6 @@ everywhereOnValues f g h = (f', g', h')

80 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

85 handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)

81 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

86 handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)

82

87

83−

84everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

88everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

85 (Declaration -> m Declaration) ->

89 (Declaration -> m Declaration) ->

86 (Expr -> m Expr) ->

90 (Expr -> m Expr) ->

@@ -97,13 +101,17 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

97 f' other = f other

101 f' other = f other

98

102

99 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

103 g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')

100− g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')

104+ g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')

101 g' (Parens v) = Parens <$> (g v >>= g')

105 g' (Parens v) = Parens <$> (g v >>= g')

106+ g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))

107+ g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))

102 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

108 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

103 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

109 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

110+ g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs

104 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

111 g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

105 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

112 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

106 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

113 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

114+ g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs

107 g' (Abs name v) = Abs name <$> (g v >>= g')

115 g' (Abs name v) = Abs name <$> (g v >>= g')

108 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

116 g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')

109 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

117 g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')

@@ -146,13 +154,17 @@ everywhereOnValuesM f g h = (f', g', h')

146 f' other = f other

154 f' other = f other

147

155

148 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

156 g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g

149− g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g

157+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g

150 g' (Parens v) = (Parens <$> g' v) >>= g

158 g' (Parens v) = (Parens <$> g' v) >>= g

159+ g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g

160+ g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g

151 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

161 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

152 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

162 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

163+ g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g

153 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

164 g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

154 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

165 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

155 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

166 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

167+ g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g

156 g' (Abs name v) = (Abs name <$> g' v) >>= g

168 g' (Abs name v) = (Abs name <$> g' v) >>= g

157 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

169 g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g

158 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

170 g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g

@@ -198,13 +210,17 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

198 f' d = f d

210 f' d = f d

199

211

200 g' v@(UnaryMinus v1) = g v <> g' v1

212 g' v@(UnaryMinus v1) = g v <> g' v1

201− g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2

213+ g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2

202 g' v@(Parens v1) = g v <> g' v1

214 g' v@(Parens v1) = g v <> g' v1

215+ g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1

216+ g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1

203 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

217 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

204 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

218 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

219+ g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))

205 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

220 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

206 g' v@(Accessor _ v1) = g v <> g' v1

221 g' v@(Accessor _ v1) = g v <> g' v1

207 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

222 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

223+ g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))

208 g' v@(Abs _ v1) = g v <> g' v1

224 g' v@(Abs _ v1) = g v <> g' v1

209 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

225 g' v@(App v1 v2) = g v <> g' v1 <> g' v2

210 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

226 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3

@@ -261,13 +277,17 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

261 g'' s v = let (s', r) = g s v in r <> g' s' v

277 g'' s v = let (s', r) = g s v in r <> g' s' v

262

278

263 g' s (UnaryMinus v1) = g'' s v1

279 g' s (UnaryMinus v1) = g'' s v1

264− g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2

280+ g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2

265 g' s (Parens v1) = g'' s v1

281 g' s (Parens v1) = g'' s v1

282+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v

283+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v

266 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

284 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

267 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

285 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

286+ g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))

268 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

287 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1

269 g' s (Accessor _ v1) = g'' s v1

288 g' s (Accessor _ v1) = g'' s v1

270 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

289 g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)

290+ g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))

271 g' s (Abs _ v1) = g'' s v1

291 g' s (Abs _ v1) = g'' s v1

272 g' s (App v1 v2) = g'' s v1 <> g'' s v2

292 g' s (App v1 v2) = g'' s v1 <> g'' s v2

273 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

293 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3

@@ -327,13 +347,17 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

327 g'' s = uncurry g' <=< g s

347 g'' s = uncurry g' <=< g s

328

348

329 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

349 g' s (UnaryMinus v) = UnaryMinus <$> g'' s v

330− g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2

350+ g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2

331 g' s (Parens v) = Parens <$> g'' s v

351 g' s (Parens v) = Parens <$> g'' s v

352+ g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)

353+ g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)

332 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

354 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

333 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

355 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

356+ g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs

334 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

357 g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v

335 g' s (Accessor prop v) = Accessor prop <$> g'' s v

358 g' s (Accessor prop v) = Accessor prop <$> g'' s v

336 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

359 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

360+ g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs

337 g' s (Abs name v) = Abs name <$> g'' s v

361 g' s (Abs name v) = Abs name <$> g'' s v

338 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

362 g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2

339 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

363 g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3

src/Language/PureScript/CodeGen/Externs.hs+10−3

@@ -45,11 +45,18 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

45

45

46 declToPs :: Declaration -> Writer [String] ()

46 declToPs :: Declaration -> Writer [String] ()

47 declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]

47 declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]

48− declToPs (FixityDeclaration (Fixity assoc prec) ident) =

48+ declToPs (FixityDeclaration (Fixity assoc prec) op) =

49+ case find exportsOp exts of

50+ Nothing -> return ()

49− tell [ unwords [ show assoc, show prec, ident ] ]

51+ Just _ -> tell [ unwords [ show assoc, show prec, op ] ]

52+ where

53+ exportsOp :: DeclarationRef -> Bool

54+ exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r

55+ exportsOp (ValueRef ident') = ident' == Op op

56+ exportsOp _ = False

50 declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d

57 declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d

51 declToPs _ = return ()

58 declToPs _ = return ()

52−

59+

53 commentToPs :: Comment -> Writer [String] ()

60 commentToPs :: Comment -> Writer [String] ()

54 commentToPs (LineComment s) = tell ["-- " ++ s]

61 commentToPs (LineComment s) = tell ["-- " ++ s]

55 commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]

62 commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]

src/Language/PureScript/CodeGen/JS.hs+48−30

@@ -13,21 +13,22 @@

13--

13--

14-----------------------------------------------------------------------------

14-----------------------------------------------------------------------------

15

15

16−{-# LANGUAGE GADTs, ViewPatterns #-}

16+{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}

17

17

18module Language.PureScript.CodeGen.JS (

18module Language.PureScript.CodeGen.JS (

19 module AST,

19 module AST,

20 module Common,

20 module Common,

21− bindToJs,

22 moduleToJs

21 moduleToJs

23) where

22) where

24

23

25import Data.List ((\\), delete)

24import Data.List ((\\), delete)

26import Data.Maybe (mapMaybe)

25import Data.Maybe (mapMaybe)

26+import qualified Data.Traversable as T (traverse)

27

27

28import Control.Applicative

28import Control.Applicative

29import Control.Arrow ((&&&))

29import Control.Arrow ((&&&))

30import Control.Monad (foldM, replicateM, forM)

30import Control.Monad (foldM, replicateM, forM)

31+import Control.Monad.Reader (MonadReader, asks, lift)

31

32

32import Language.PureScript.CodeGen.JS.AST as AST

33import Language.PureScript.CodeGen.JS.AST as AST

33import Language.PureScript.CodeGen.JS.Common as Common

34import Language.PureScript.CodeGen.JS.Common as Common

@@ -43,16 +44,18 @@ import qualified Language.PureScript.Constants as C

43-- Generate code in the simplified Javascript intermediate representation for all declarations in a

44-- Generate code in the simplified Javascript intermediate representation for all declarations in a

44-- module.

45-- module.

45--

46--

46−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]

47+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

48+ => Module Ann -> SupplyT m [JS]

47−moduleToJs opts (Module name imps exps foreigns decls) = do

49+moduleToJs (Module name imps exps foreigns decls) = do

50+ additional <- lift $ asks optionsAdditional

48− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

51+ jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

49 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

52 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

50 jsDecls <- mapM (bindToJs name) decls

53 jsDecls <- mapM (bindToJs name) decls

51− let optimized = concatMap (map $ optimize opts) jsDecls

54+ optimized <- lift $ T.traverse (T.traverse optimize) jsDecls

52 let isModuleEmpty = null exps

55 let isModuleEmpty = null exps

53− let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized

56+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized

54 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

57 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

55− return $ case optionsAdditional opts of

58+ return $ case additional of

56 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

59 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

57 CompileOptions ns _ _ | not isModuleEmpty ->

60 CompileOptions ns _ _ | not isModuleEmpty ->

58 [ JSVariableIntroduction ns

61 [ JSVariableIntroduction ns

@@ -65,18 +68,19 @@ moduleToJs opts (Module name imps exps foreigns decls) = do

65-- |

68-- |

66-- Generates Javascript code for a module import.

69-- Generates Javascript code for a module import.

67--

70--

68−importToJs :: Options mode -> ModuleName -> JS

71+importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS

69−importToJs opts mn =

72+importToJs mn = do

70− JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

71− where

72− moduleBody = case optionsAdditional opts of

73+ additional <- asks optionsAdditional

74+ let moduleBody = case additional of

73− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

75+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

74− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)

76+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)

77+ return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

75

78

76-- |

79-- |

77-- Generate code in the simplified Javascript intermediate representation for a declaration

80-- Generate code in the simplified Javascript intermediate representation for a declaration

78--

81--

82+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

79−bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS]

83+ => ModuleName -> Bind Ann -> SupplyT m [JS]

80bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val

84bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val

81bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

85bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

82

86

@@ -86,9 +90,13 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

86--

90--

87-- The main purpose of this function is to handle code generation for comments.

91-- The main purpose of this function is to handle code generation for comments.

88--

92--

93+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

89−nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS

94+ => ModuleName -> Ident -> Expr Ann -> SupplyT m JS

90−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =

95+nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

96+ withoutComment <- lift $ asks optionsNoComments

97+ if withoutComment

98+ then nonRecToJS m i (modifyAnn removeComments e)

91− JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)

99+ else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)

92nonRecToJS mp ident val = do

100nonRecToJS mp ident val = do

93 js <- valueToJs mp val

101 js <- valueToJs mp val

94 return $ JSVariableIntroduction (identToJs ident) (Just js)

102 return $ JSVariableIntroduction (identToJs ident) (Just js)

@@ -117,7 +125,8 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

117-- |

125-- |

118-- Generate code in the simplified Javascript intermediate representation for a value or expression.

126-- Generate code in the simplified Javascript intermediate representation for a value or expression.

119--

127--

128+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

120−valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS

129+ => ModuleName -> Expr Ann -> SupplyT m JS

121valueToJs m (Literal _ l) =

130valueToJs m (Literal _ l) =

122 literalToValueJS m l

131 literalToValueJS m l

123valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

132valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

@@ -128,7 +137,7 @@ valueToJs m (Accessor _ prop val) =

128 accessorString prop <$> valueToJs m val

137 accessorString prop <$> valueToJs m val

129valueToJs m (ObjectUpdate _ o ps) = do

138valueToJs m (ObjectUpdate _ o ps) = do

130 obj <- valueToJs m o

139 obj <- valueToJs m o

131− sts <- mapM (sndM (valueToJs m)) ps

140+ sts <- mapM (sndM $ valueToJs m) ps

132 extendObj obj sts

141 extendObj obj sts

133valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

142valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

134 let args = unAbs e

143 let args = unAbs e

@@ -191,7 +200,8 @@ valueToJs _ (Constructor _ _ (ProperName ctor) fields) =

191iife :: String -> [JS] -> JS

200iife :: String -> [JS] -> JS

192iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

201iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

193

202

203+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

194−literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

204+ => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

195literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

205literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

196literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

206literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

197literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

207literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -238,7 +248,8 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

238-- Generate code in the simplified Javascript intermediate representation for pattern match binders

248-- Generate code in the simplified Javascript intermediate representation for pattern match binders

239-- and guards.

249-- and guards.

240--

250--

251+bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

241−bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

252+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

242bindersToJs m binders vals = do

253bindersToJs m binders vals = do

243 valNames <- replicateM (length vals) freshName

254 valNames <- replicateM (length vals) freshName

244 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

255 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

@@ -248,14 +259,16 @@ bindersToJs m binders vals = do

248 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

259 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

249 []

260 []

250 where

261 where

262+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

251− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

263+ => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

252 go _ done [] = return done

264 go _ done [] = return done

253 go (v:vs) done' (b:bs) = do

265 go (v:vs) done' (b:bs) = do

254 done'' <- go vs done' bs

266 done'' <- go vs done' bs

255 binderToJs m v done'' b

267 binderToJs m v done'' b

256 go _ _ _ = error "Invalid arguments to bindersToJs"

268 go _ _ _ = error "Invalid arguments to bindersToJs"

257

269

270+ guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

258− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

271+ => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

259 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

272 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

260 cond' <- valueToJs m cond

273 cond' <- valueToJs m cond

261 done <- valueToJs m val

274 done <- valueToJs m val

@@ -266,7 +279,8 @@ bindersToJs m binders vals = do

266-- Generate code in the simplified Javascript intermediate representation for a pattern match

279-- Generate code in the simplified Javascript intermediate representation for a pattern match

267-- binder.

280-- binder.

268--

281--

282+binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

269−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

283+ => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

270binderToJs _ _ done (NullBinder{}) = return done

284binderToJs _ _ done (NullBinder{}) = return done

271binderToJs m varName done (LiteralBinder _ l) =

285binderToJs m varName done (LiteralBinder _ l) =

272 literalToBinderJS m varName done l

286 literalToBinderJS m varName done l

@@ -283,7 +297,8 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT

283 (JSBlock js)

297 (JSBlock js)

284 Nothing]

298 Nothing]

285 where

299 where

300+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

286− go :: (Functor m, Applicative m, Monad m) => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]

301+ => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]

287 go [] done' = return done'

302 go [] done' = return done'

288 go ((field, binder) : remain) done' = do

303 go ((field, binder) : remain) done' = do

289 argVar <- freshName

304 argVar <- freshName

@@ -313,7 +328,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do

313 js <- binderToJs m varName done binder

328 js <- binderToJs m varName done binder

314 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

329 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

315

330

331+literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

316−literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

332+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

317literalToBinderJS _ varName done (NumericLiteral num) =

333literalToBinderJS _ varName done (NumericLiteral num) =

318 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

334 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

319literalToBinderJS _ varName done (StringLiteral str) =

335literalToBinderJS _ varName done (StringLiteral str) =

@@ -324,7 +340,8 @@ literalToBinderJS _ varName done (BooleanLiteral False) =

324 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

340 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

325literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

341literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

326 where

342 where

343+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

327− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

344+ => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

328 go done' [] = return done'

345 go done' [] = return done'

329 go done' ((prop, binder):bs') = do

346 go done' ((prop, binder):bs') = do

330 propVar <- freshName

347 propVar <- freshName

@@ -335,7 +352,8 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do

335 js <- go done 0 bs

352 js <- go done 0 bs

336 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

353 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

337 where

354 where

355+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

338− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

356+ => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

339 go done' _ [] = return done'

357 go done' _ [] = return done'

340 go done' index (binder:bs') = do

358 go done' index (binder:bs') = do

341 elVar <- freshName

359 elVar <- freshName

src/Language/PureScript/CodeGen/JS/Common.hs+42−2

@@ -135,7 +135,47 @@ nameIsJsReserved name =

135 , "volatile"

135 , "volatile"

136 , "while"

136 , "while"

137 , "with"

137 , "with"

138− , "yield" ]

138+ , "yield" ] || properNameIsJsReserved name

139

139

140moduleNameToJs :: ModuleName -> String

140moduleNameToJs :: ModuleName -> String

141+moduleNameToJs (ModuleName pns) =

141−moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

142+ let name = intercalate "_" (runProperName `map` pns)

143+ in if properNameIsJsReserved name then "$$" ++ name else name

144+

145+-- |

146+-- Checks whether a proper name is reserved in Javascript.

147+--

148+properNameIsJsReserved :: String -> Bool

149+properNameIsJsReserved name =

150+ name `elem` [ "Infinity"

151+ , "NaN"

152+ , "Object"

153+ , "Function"

154+ , "Boolean"

155+ , "Error"

156+ , "EvalError"

157+ , "InternalError"

158+ , "RangeError"

159+ , "ReferenceError"

160+ , "SyntaxError"

161+ , "TypeError"

162+ , "URIError"

163+ , "Number"

164+ , "Math"

165+ , "Date"

166+ , "String"

167+ , "RegExp"

168+ , "Array"

169+ , "Int8Array"

170+ , "Uint8Array"

171+ , "Uint8ClampedArray"

172+ , "Int16Array"

173+ , "Uint16Array"

174+ , "Int32Array"

175+ , "Uint32Array"

176+ , "Float32Array"

177+ , "Float64Array"

178+ , "ArrayBuffer"

179+ , "DataView"

180+ , "JSON"

181+ , "Intl" ]

src/Language/PureScript/CodeGen/JS/Optimizer.hs+29−19

@@ -31,10 +31,14 @@

31--

31--

32-----------------------------------------------------------------------------

32-----------------------------------------------------------------------------

33

33

34+{-# LANGUAGE FlexibleContexts #-}

35+

34module Language.PureScript.CodeGen.JS.Optimizer (

36module Language.PureScript.CodeGen.JS.Optimizer (

35 optimize

37 optimize

36) where

38) where

37

39

40+import Control.Monad.Reader (MonadReader, ask, asks)

41+

38import Language.PureScript.CodeGen.JS.AST

42import Language.PureScript.CodeGen.JS.AST

39import Language.PureScript.Options

43import Language.PureScript.Options

40import qualified Language.PureScript.Constants as C

44import qualified Language.PureScript.Constants as C

@@ -49,28 +53,34 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks

49-- |

53-- |

50-- Apply a series of optimizer passes to simplified Javascript code

54-- Apply a series of optimizer passes to simplified Javascript code

51--

55--

52−optimize :: Options mode -> JS -> JS

56+optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS

57+optimize js = do

53−optimize opts | optionsNoOptimizations opts = id

58+ noOpt <- asks optionsNoOptimizations

59+ if noOpt then return js else optimize' js

60+

61+optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS

62+optimize' js = do

63+ opts <- ask

54− | otherwise = untilFixedPoint (applyAll

64+ return $ untilFixedPoint (applyAll

55− [ collapseNestedBlocks

65+ [ collapseNestedBlocks

56− , collapseNestedIfs

66+ , collapseNestedIfs

57− , tco opts

67+ , tco opts

58− , magicDo opts

68+ , magicDo opts

59− , removeCodeAfterReturnStatements

69+ , removeCodeAfterReturnStatements

60− , removeUnusedArg

70+ , removeUnusedArg

61− , removeUndefinedApp

71+ , removeUndefinedApp

62− , unThunk

72+ , unThunk

63− , etaConvert

73+ , etaConvert

64− , evaluateIifes

74+ , evaluateIifes

65− , inlineVariables

75+ , inlineVariables

76+ , inlineValues

66− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

77+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

67− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

78+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

68− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

79+ , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

69− , inlineCommonOperators ])

80+ , inlineCommonOperators ]) js

70

81

71untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

82untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

72untilFixedPoint f = go

83untilFixedPoint f = go

73 where

84 where

74 go a = let a' = f a in

85 go a = let a' = f a in

75 if a' == a then a' else go a'

86 if a' == a then a' else go a'

76−

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+28−18

@@ -15,6 +15,7 @@

15

15

16module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

16module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

17 inlineVariables,

17 inlineVariables,

18+ inlineValues,

18 inlineOperator,

19 inlineOperator,

19 inlineCommonOperators,

20 inlineCommonOperators,

20 etaConvert,

21 etaConvert,

@@ -79,6 +80,15 @@ inlineVariables = everywhereOnJS $ removeFromBlock go

79 go (map (replaceIdent var js) sts)

80 go (map (replaceIdent var js) sts)

80 go (s:sts) = s : go sts

81 go (s:sts) = s : go sts

81

82

83+inlineValues :: JS -> JS

84+inlineValues = everywhereOnJS convert

85+ where

86+ convert :: JS -> JS

87+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)

88+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)

89+ convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y

90+ convert other = other

91+

82inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

92inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

83inlineOperator (m, op) f = everywhereOnJS convert

93inlineOperator (m, op) f = everywhereOnJS convert

84 where

94 where

@@ -91,12 +101,11 @@ inlineOperator (m, op) f = everywhereOnJS convert

91

101

92inlineCommonOperators :: JS -> JS

102inlineCommonOperators :: JS -> JS

93inlineCommonOperators = applyAll $

103inlineCommonOperators = applyAll $

94− [ binary C.numNumber (C.+) Add

104+ [ binary C.semiringNumber (C.+) Add

95− , binary C.numNumber (C.-) Subtract

105+ , binary C.semiringNumber (C.*) Multiply

96− , binary C.numNumber (C.*) Multiply

106+ , binary C.ringNumber (C.-) Subtract

97− , binary C.numNumber (C./) Divide

98− , binary C.numNumber (C.%) Modulus

99− , unary C.numNumber C.negate Negate

107+ , unary C.ringNumber C.negate Negate

108+ , binary C.moduloSemiringNumber (C./) Divide

100

109

101 , binary C.ordNumber (C.<) LessThan

110 , binary C.ordNumber (C.<) LessThan

102 , binary C.ordNumber (C.>) GreaterThan

111 , binary C.ordNumber (C.>) GreaterThan

@@ -131,29 +140,20 @@ inlineCommonOperators = applyAll $

131 binary dictName opString op = everywhereOnJS convert

140 binary dictName opString op = everywhereOnJS convert

132 where

141 where

133 convert :: JS -> JS

142 convert :: JS -> JS

134− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

143+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y

135 convert other = other

144 convert other = other

136− isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)

137− isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'

138− isOp _ = False

139 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

145 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

140 binaryFunction dictName fnName op = everywhereOnJS convert

146 binaryFunction dictName fnName op = everywhereOnJS convert

141 where

147 where

142 convert :: JS -> JS

148 convert :: JS -> JS

143− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

149+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y

144 convert other = other

150 convert other = other

145− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'

146− isOp _ = False

147 unary :: String -> String -> UnaryOperator -> JS -> JS

151 unary :: String -> String -> UnaryOperator -> JS -> JS

148 unary dictName fnName op = everywhereOnJS convert

152 unary dictName fnName op = everywhereOnJS convert

149 where

153 where

150 convert :: JS -> JS

154 convert :: JS -> JS

151− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

155+ convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x

152 convert other = other

156 convert other = other

153− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

154− isOp _ = False

155− isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName

156− isOpDict _ _ = False

157 mkFn :: Int -> JS -> JS

157 mkFn :: Int -> JS -> JS

158 mkFn 0 = everywhereOnJS convert

158 mkFn 0 = everywhereOnJS convert

159 where

159 where

@@ -189,3 +189,13 @@ inlineCommonOperators = applyAll $

189 go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)

189 go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)

190 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

190 go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

191 go _ _ _ = Nothing

191 go _ _ _ = Nothing

192+

193+isPreludeDict :: String -> JS -> Bool

194+isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName

195+isPreludeDict _ _ = False

196+

197+isPreludeFn :: String -> JS -> Bool

198+isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

199+isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

200+isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)

201+isPreludeFn _ _ = False

src/Language/PureScript/Comments.hs+2−2

@@ -18,8 +18,8 @@

18module Language.PureScript.Comments where

18module Language.PureScript.Comments where

19

19

20import qualified Data.Data as D

20import qualified Data.Data as D

21−

21+

22data Comment

22data Comment

23 = LineComment String

23 = LineComment String

24 | BlockComment String

24 | BlockComment String

25− deriving (Show, Eq, Ord, D.Data, D.Typeable)

25+ deriving (Show, Eq, Ord, D.Data, D.Typeable)

src/Language/PureScript/Constants.hs+15

@@ -105,6 +105,12 @@ not = "not"

105

105

106-- Prelude Values

106-- Prelude Values

107

107

108+zero :: String

109+zero = "zero"

110+

111+one :: String

112+one = "one"

113+

108return :: String

114return :: String

109return = "return"

115return = "return"

110

116

@@ -163,6 +169,15 @@ applicativeEffDictionary = "applicativeEff"

163bindEffDictionary :: String

169bindEffDictionary :: String

164bindEffDictionary = "bindEff"

170bindEffDictionary = "bindEff"

165

171

172+semiringNumber :: String

173+semiringNumber = "semiringNumber"

174+

175+ringNumber :: String

176+ringNumber = "ringNumber"

177+

178+moduloSemiringNumber :: String

179+moduloSemiringNumber = "moduloSemiringNumber"

180+

166numNumber :: String

181numNumber :: String

167numNumber = "numNumber"

182numNumber = "numNumber"

168

183

src/Language/PureScript/CoreFn/Ann.hs+1−1

@@ -34,4 +34,4 @@ nullAnn = (Nothing, [], Nothing, Nothing)

34-- Remove the comments from an annotation

34-- Remove the comments from an annotation

35--

35--

36removeComments :: Ann -> Ann

36removeComments :: Ann -> Ann

37−removeComments (ss, _, ty, meta) = (ss, [], ty, meta)

37+removeComments (ss, _, ty, meta) = (ss, [], ty, meta)

src/Language/PureScript/CoreFn/Binders.hs+2−1

@@ -13,6 +13,7 @@

13-----------------------------------------------------------------------------

13-----------------------------------------------------------------------------

14

14

15{-# LANGUAGE DeriveDataTypeable #-}

15{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

16

17

17module Language.PureScript.CoreFn.Binders where

18module Language.PureScript.CoreFn.Binders where

18

19

@@ -44,4 +45,4 @@ data Binder a

44 -- |

45 -- |

45 -- A binder which binds its input to an identifier

46 -- A binder which binds its input to an identifier

46 --

47 --

47− | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)

48+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)

src/Language/PureScript/CoreFn/Expr.hs+12−2

@@ -13,9 +13,12 @@

13-----------------------------------------------------------------------------

13-----------------------------------------------------------------------------

14

14

15{-# LANGUAGE DeriveDataTypeable #-}

15{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

16

17

17module Language.PureScript.CoreFn.Expr where

18module Language.PureScript.CoreFn.Expr where

18

19

20+import Control.Arrow ((***))

21+

19import qualified Data.Data as D

22import qualified Data.Data as D

20

23

21import Language.PureScript.CoreFn.Binders

24import Language.PureScript.CoreFn.Binders

@@ -61,7 +64,7 @@ data Expr a

61 -- |

64 -- |

62 -- A let binding

65 -- A let binding

63 --

66 --

64− | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)

67+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)

65

68

66-- |

69-- |

67-- A let or module binding.

70-- A let or module binding.

@@ -74,7 +77,7 @@ data Bind a

74 -- |

77 -- |

75 -- Mutually recursive binding group for several values

78 -- Mutually recursive binding group for several values

76 --

79 --

77− | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)

80+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)

78

81

79-- |

82-- |

80-- A guard is just a boolean-valued expression that appears alongside a set of binders

83-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -95,6 +98,12 @@ data CaseAlternative a = CaseAlternative

95 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

98 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

96 } deriving (Show, D.Data, D.Typeable)

99 } deriving (Show, D.Data, D.Typeable)

97

100

101+instance Functor CaseAlternative where

102+

103+ fmap f (CaseAlternative cabs car) = CaseAlternative

104+ (fmap (fmap f) $ cabs)

105+ (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)

106+

98-- |

107-- |

99-- Extract the annotation from a term

108-- Extract the annotation from a term

100--

109--

@@ -109,6 +118,7 @@ extractAnn (Var a _) = a

109extractAnn (Case a _ _) = a

118extractAnn (Case a _ _) = a

110extractAnn (Let a _ _) = a

119extractAnn (Let a _ _) = a

111

120

121+

112-- |

122-- |

113-- Modify the annotation on a term

123-- Modify the annotation on a term

114--

124--

src/Language/PureScript/CoreFn/Literals.hs+2−1

@@ -13,6 +13,7 @@

13-----------------------------------------------------------------------------

13-----------------------------------------------------------------------------

14

14

15{-# LANGUAGE DeriveDataTypeable #-}

15{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

16

17

17module Language.PureScript.CoreFn.Literals where

18module Language.PureScript.CoreFn.Literals where

18

19

@@ -42,4 +43,4 @@ data Literal a

42 -- |

43 -- |

43 -- An object literal

44 -- An object literal

44 --

45 --

45− | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)

46+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)

src/Language/PureScript/Environment.hs+6−1

@@ -136,7 +136,12 @@ data TypeKind

136 -- |

136 -- |

137 -- A local type variable

137 -- A local type variable

138 --

138 --

139+ | LocalTypeVariable

140+ -- |

141+ -- A scoped type variable

142+ --

143+ | ScopedTypeVar

139− | LocalTypeVariable deriving (Show, Eq, Data, Typeable)

144+ deriving (Show, Eq, Data, Typeable)

140

145

141-- |

146-- |

142-- The type ('data' or 'newtype') of a data type declaration

147-- The type ('data' or 'newtype') of a data type declaration

src/Language/PureScript/Errors.hs+2−2

@@ -95,8 +95,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) =

95prettyPrintErrorStack printFullStack (MultipleErrors es) =

95prettyPrintErrorStack printFullStack (MultipleErrors es) =

96 unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

96 unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

97

97

98−stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a

98+stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a

99−stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

99+stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return

100

100

101isErrorNonEmpty :: CompileError -> Bool

101isErrorNonEmpty :: CompileError -> Bool

102isErrorNonEmpty = not . null . compileErrorMessage

102isErrorNonEmpty = not . null . compileErrorMessage

src/Language/PureScript/ModuleDependencies.hs+7−4

@@ -12,11 +12,15 @@

12--

12--

13-----------------------------------------------------------------------------

13-----------------------------------------------------------------------------

14

14

15+{-# LANGUAGE FlexibleContexts #-}

16+

15module Language.PureScript.ModuleDependencies (

17module Language.PureScript.ModuleDependencies (

16 sortModules,

18 sortModules,

17 ModuleGraph

19 ModuleGraph

18) where

20) where

19

21

22+import Control.Monad.Error.Class

23+

20import Data.Graph

24import Data.Graph

21import Data.List (nub)

25import Data.List (nub)

22import Data.Maybe (mapMaybe)

26import Data.Maybe (mapMaybe)

@@ -35,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

35--

39--

36-- Reports an error if the module graph contains a cycle.

40-- Reports an error if the module graph contains a cycle.

37--

41--

38−sortModules :: [Module] -> Either String ([Module], ModuleGraph)

42+sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)

39sortModules ms = do

43sortModules ms = do

40 let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

44 let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

41 ms' <- mapM toModule $ stronglyConnComp verts

45 ms' <- mapM toModule $ stronglyConnComp verts

@@ -54,7 +58,6 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

54

58

55 forValues :: Expr -> [ModuleName]

59 forValues :: Expr -> [ModuleName]

56 forValues (Var (Qualified (Just mn) _)) = [mn]

60 forValues (Var (Qualified (Just mn) _)) = [mn]

57− forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]

58 forValues (Constructor (Qualified (Just mn) _)) = [mn]

61 forValues (Constructor (Qualified (Just mn) _)) = [mn]

59 forValues (TypedValue _ _ ty) = forTypes ty

62 forValues (TypedValue _ _ ty) = forTypes ty

60 forValues _ = []

63 forValues _ = []

@@ -67,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

67-- |

70-- |

68-- Convert a strongly connected component of the module graph to a module

71-- Convert a strongly connected component of the module graph to a module

69--

72--

70−toModule :: SCC Module -> Either String Module

73+toModule :: (MonadError String m) => SCC Module -> m Module

71toModule (AcyclicSCC m) = return m

74toModule (AcyclicSCC m) = return m

72toModule (CyclicSCC [m]) = return m

75toModule (CyclicSCC [m]) = return m

73−toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms)

76+toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)

src/Language/PureScript/Options.hs+5−2

@@ -69,6 +69,9 @@ data Options mode = Options {

69 -- Verbose error message

69 -- Verbose error message

70 --

70 --

71 , optionsVerboseErrors :: Bool

71 , optionsVerboseErrors :: Bool

72+ -- |

73+ -- Remove the comments from the generated js

74+ , optionsNoComments :: Bool

72 -- |

75 -- |

73 -- Specify the namespace that PureScript modules will be exported to when running in the

76 -- Specify the namespace that PureScript modules will be exported to when running in the

74 -- browser.

77 -- browser.

@@ -80,10 +83,10 @@ data Options mode = Options {

80-- Default compiler options

83-- Default compiler options

81--

84--

82defaultCompileOptions :: Options Compile

85defaultCompileOptions :: Options Compile

83−defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])

86+defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])

84

87

85-- |

88-- |

86-- Default make options

89-- Default make options

87--

90--

88defaultMakeOptions :: Options Make

91defaultMakeOptions :: Options Make

89−defaultMakeOptions = Options False False False Nothing False False MakeOptions

92+defaultMakeOptions = Options False False False Nothing False False False MakeOptions

src/Language/PureScript/Parser.hs+1−1

@@ -32,4 +32,4 @@ import Language.PureScript.Parser.Types as P

32import Language.PureScript.Parser.State as P

32import Language.PureScript.Parser.State as P

33import Language.PureScript.Parser.Kinds as P

33import Language.PureScript.Parser.Kinds as P

34import Language.PureScript.Parser.Lexer as P

34import Language.PureScript.Parser.Lexer as P

35−import Language.PureScript.Parser.Declarations as P

35+import Language.PureScript.Parser.Declarations as P

src/Language/PureScript/Parser/Common.hs−6

@@ -88,12 +88,6 @@ buildPostfixParser fs first = do

88 Nothing -> return a

88 Nothing -> return a

89 Just a' -> go a'

89 Just a' -> go a'

90

90

91−-- |

92−-- Parse an identifier in backticks or an operator

93−--

94−parseIdentInfix :: TokenParser (Qualified Ident)

95−parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))

96−

97-- |

91-- |

98-- Mark the current indentation level

92-- Mark the current indentation level

99--

93--

src/Language/PureScript/Parser/Declarations.hs+37−9

@@ -41,6 +41,7 @@ import Language.PureScript.Parser.Common

41import Language.PureScript.Parser.Types

41import Language.PureScript.Parser.Types

42import Language.PureScript.Parser.Kinds

42import Language.PureScript.Parser.Kinds

43import Language.PureScript.Parser.Lexer

43import Language.PureScript.Parser.Lexer

44+import Language.PureScript.Names

44import Language.PureScript.CodeGen.JS.AST

45import Language.PureScript.CodeGen.JS.AST

45import Language.PureScript.Environment

46import Language.PureScript.Environment

46

47

@@ -285,11 +286,13 @@ parseArrayLiteral :: TokenParser Expr

285parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

286parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

286

287

287parseObjectLiteral :: TokenParser Expr

288parseObjectLiteral :: TokenParser Expr

288−parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)

289+parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

289

290

290−parseIdentifierAndValue :: TokenParser (String, Expr)

291+parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

291parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)

292parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)

292− <*> (C.indented *> parseValue)

293+ <*> (C.indented *> val)

294+ where

295+ val = (Just <$> parseValue) <|> (underscore *> pure Nothing)

293

296

294parseAbs :: TokenParser Expr

297parseAbs :: TokenParser Expr

295parseAbs = do

298parseAbs = do

@@ -343,6 +346,7 @@ parseValueAtom = P.choice

343 , P.try parseBooleanLiteral

346 , P.try parseBooleanLiteral

344 , parseArrayLiteral

347 , parseArrayLiteral

345 , P.try parseObjectLiteral

348 , P.try parseObjectLiteral

349+ , P.try parseObjectGetter

346 , parseAbs

350 , parseAbs

347 , P.try parseConstructor

351 , P.try parseConstructor

348 , P.try parseVar

352 , P.try parseVar

@@ -350,13 +354,28 @@ parseValueAtom = P.choice

350 , parseIfThenElse

354 , parseIfThenElse

351 , parseDo

355 , parseDo

352 , parseLet

356 , parseLet

353− , Parens <$> parens parseValue ]

357+ , P.try $ Parens <$> parens parseValue

358+ , parseOperatorSection

359+ , P.try parseObjectUpdaterWildcard ]

354

360

361+-- |

362+-- Parse an expression in backticks or an operator

363+--

364+parseInfixExpr :: TokenParser Expr

365+parseInfixExpr = P.between tick tick parseValue

366+ <|> Var <$> parseQualified (Op <$> symbol)

367+

368+parseOperatorSection :: TokenParser Expr

369+parseOperatorSection = parens $ left <|> right

370+ where

371+ right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)

372+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr

373+

355−parsePropertyUpdate :: TokenParser (String, Expr)

374+parsePropertyUpdate :: TokenParser (String, Maybe Expr)

356parsePropertyUpdate = do

375parsePropertyUpdate = do

357 name <- lname <|> stringLiteral

376 name <- lname <|> stringLiteral

358 _ <- C.indented *> equals

377 _ <- C.indented *> equals

359− value <- C.indented *> parseValue

378+ value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

360 return (name, value)

379 return (name, value)

361

380

362parseAccessor :: Expr -> TokenParser Expr

381parseAccessor :: Expr -> TokenParser Expr

@@ -381,6 +400,9 @@ parseDoNotationElement = P.choice

381 , parseDoNotationLet

400 , parseDoNotationLet

382 , P.try (DoNotationValue <$> parseValue) ]

401 , P.try (DoNotationValue <$> parseValue) ]

383

402

403+parseObjectGetter :: TokenParser Expr

404+parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

405+

384-- |

406-- |

385-- Parse a value

407-- Parse a value

386--

408--

@@ -392,17 +414,23 @@ parseValue = withSourceSpan PositionedValue

392 where

414 where

393 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

415 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

394 postfixTable1 = [ parseAccessor

416 postfixTable1 = [ parseAccessor

395− , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

417+ , P.try . parseUpdaterBody . Just ]

396 postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

418 postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

397 , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v

419 , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v

398 ]

420 ]

399 operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

421 operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

400 ]

422 ]

401− , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

423+ , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

402 return (BinaryNoParens ident)) P.AssocRight

424 return (BinaryNoParens ident)) P.AssocRight

403 ]

425 ]

404 ]

426 ]

405

427

428+parseUpdaterBody :: Maybe Expr -> TokenParser Expr

429+parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

430+

431+parseObjectUpdaterWildcard :: TokenParser Expr

432+parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing

433+

406parseStringBinder :: TokenParser Binder

434parseStringBinder :: TokenParser Binder

407parseStringBinder = StringBinder <$> stringLiteral

435parseStringBinder = StringBinder <$> stringLiteral

408

436

@@ -437,7 +465,7 @@ parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)

437 <*> (C.indented *> parseBinder)

465 <*> (C.indented *> parseBinder)

438

466

439parseNullBinder :: TokenParser Binder

467parseNullBinder :: TokenParser Binder

440−parseNullBinder = reserved "_" *> return NullBinder

468+parseNullBinder = underscore *> return NullBinder

441

469

442parseIdentifierAndBinder :: TokenParser (String, Binder)

470parseIdentifierAndBinder :: TokenParser (String, Binder)

443parseIdentifierAndBinder = do

471parseIdentifierAndBinder = do

src/Language/PureScript/Parser/Lexer.hs+38−30

@@ -15,7 +15,7 @@

15

15

16{-# LANGUAGE TupleSections #-}

16{-# LANGUAGE TupleSections #-}

17

17

18−module Language.PureScript.Parser.Lexer

18+module Language.PureScript.Parser.Lexer

19 ( PositionedToken(..)

19 ( PositionedToken(..)

20 , Token()

20 , Token()

21 , TokenParser()

21 , TokenParser()

@@ -34,8 +34,8 @@ module Language.PureScript.Parser.Lexer

34 , squares

34 , squares

35 , indent

35 , indent

36 , indentAt

36 , indentAt

37− , larrow

37+ , larrow

38− , rarrow

38+ , rarrow

39 , lfatArrow

39 , lfatArrow

40 , rfatArrow

40 , rfatArrow

41 , colon

41 , colon

@@ -47,6 +47,7 @@ module Language.PureScript.Parser.Lexer

47 , comma

47 , comma

48 , semi

48 , semi

49 , at

49 , at

50+ , underscore

50 , semiSep

51 , semiSep

51 , semiSep1

52 , semiSep1

52 , commaSep

53 , commaSep

@@ -83,7 +84,7 @@ import Language.PureScript.Comments

83

84

84import qualified Text.Parsec as P

85import qualified Text.Parsec as P

85import qualified Text.Parsec.Token as PT

86import qualified Text.Parsec.Token as PT

86−

87+

87data Token

88data Token

88 = LParen

89 = LParen

89 | RParen

90 | RParen

@@ -105,6 +106,7 @@ data Token

105 | Comma

106 | Comma

106 | Semi

107 | Semi

107 | At

108 | At

109+ | Underscore

108 | LName String

110 | LName String

109 | UName String

111 | UName String

110 | Qualifier String

112 | Qualifier String

@@ -112,7 +114,7 @@ data Token

112 | StringLiteral String

114 | StringLiteral String

113 | Number (Either Integer Double)

115 | Number (Either Integer Double)

114 deriving (Show, Eq, Ord)

116 deriving (Show, Eq, Ord)

115−

117+

116prettyPrintToken :: Token -> String

118prettyPrintToken :: Token -> String

117prettyPrintToken LParen = "("

119prettyPrintToken LParen = "("

118prettyPrintToken RParen = ")"

120prettyPrintToken RParen = ")"

@@ -133,6 +135,7 @@ prettyPrintToken Dot = "."

133prettyPrintToken Comma = ","

135prettyPrintToken Comma = ","

134prettyPrintToken Semi = ";"

136prettyPrintToken Semi = ";"

135prettyPrintToken At = "@"

137prettyPrintToken At = "@"

138+prettyPrintToken Underscore = "_"

136prettyPrintToken (Indent n) = "indentation at level " ++ show n

139prettyPrintToken (Indent n) = "indentation at level " ++ show n

137prettyPrintToken (LName s) = show s

140prettyPrintToken (LName s) = show s

138prettyPrintToken (UName s) = show s

141prettyPrintToken (UName s) = show s

@@ -146,19 +149,19 @@ data PositionedToken = PositionedToken

146 , ptToken :: Token

149 , ptToken :: Token

147 , ptComments :: [Comment]

150 , ptComments :: [Comment]

148 } deriving (Eq)

151 } deriving (Eq)

149−

152+

150instance Show PositionedToken where

153instance Show PositionedToken where

151 show = show . ptToken

154 show = show . ptToken

152

155

153lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

156lex :: FilePath -> String -> Either P.ParseError [PositionedToken]

154lex filePath input = P.parse parseTokens filePath input

157lex filePath input = P.parse parseTokens filePath input

155−

158+

156parseTokens :: P.Parsec String u [PositionedToken]

159parseTokens :: P.Parsec String u [PositionedToken]

157parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof

160parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof

158

161

159whitespace :: P.Parsec String u ()

162whitespace :: P.Parsec String u ()

160whitespace = P.skipMany (P.satisfy isSpace)

163whitespace = P.skipMany (P.satisfy isSpace)

161−

164+

162parseComment :: P.Parsec String u Comment

165parseComment :: P.Parsec String u Comment

163parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

166parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace

164 where

167 where

@@ -177,11 +180,11 @@ parsePositionedToken = P.try $ do

177

180

178parseToken :: P.Parsec String u Token

181parseToken :: P.Parsec String u Token

179parseToken = P.choice

182parseToken = P.choice

180− [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

183+ [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow

181 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

184 , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow

182− , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

185+ , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow

183− , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

186+ , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow

184− , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

187+ , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon

185 , P.try $ P.char '(' *> pure LParen

188 , P.try $ P.char '(' *> pure LParen

186 , P.try $ P.char ')' *> pure RParen

189 , P.try $ P.char ')' *> pure RParen

187 , P.try $ P.char '{' *> pure LBrace

190 , P.try $ P.char '{' *> pure LBrace

@@ -196,10 +199,11 @@ parseToken = P.choice

196 , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot

199 , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot

197 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

200 , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi

198 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

201 , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At

202+ , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore

199− , LName <$> parseLName

203+ , LName <$> parseLName

200 , do uName <- parseUName

204 , do uName <- parseUName

201 (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)

205 (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)

202− , Symbol <$> parseSymbol

206+ , Symbol <$> parseSymbol

203 , StringLiteral <$> parseStringLiteral

207 , StringLiteral <$> parseStringLiteral

204 , Number <$> parseNumber

208 , Number <$> parseNumber

205 ] <* whitespace

209 ] <* whitespace

@@ -207,16 +211,16 @@ parseToken = P.choice

207 where

211 where

208 parseLName :: P.Parsec String u String

212 parseLName :: P.Parsec String u String

209 parseLName = (:) <$> identStart <*> P.many identLetter

213 parseLName = (:) <$> identStart <*> P.many identLetter

210−

214+

211 parseUName :: P.Parsec String u String

215 parseUName :: P.Parsec String u String

212 parseUName = (:) <$> P.upper <*> P.many uidentLetter

216 parseUName = (:) <$> P.upper <*> P.many uidentLetter

213−

217+

214 parseSymbol :: P.Parsec String u String

218 parseSymbol :: P.Parsec String u String

215 parseSymbol = P.many1 symbolChar

219 parseSymbol = P.many1 symbolChar

216−

220+

217 identStart :: P.Parsec String u Char

221 identStart :: P.Parsec String u Char

218 identStart = P.lower <|> P.oneOf "_"

222 identStart = P.lower <|> P.oneOf "_"

219−

223+

220 identLetter :: P.Parsec String u Char

224 identLetter :: P.Parsec String u Char

221 identLetter = P.alphaNum <|> P.oneOf "_'"

225 identLetter = P.alphaNum <|> P.oneOf "_'"

222

226

@@ -225,13 +229,13 @@ parseToken = P.choice

225

229

226 symbolChar :: P.Parsec String u Char

230 symbolChar :: P.Parsec String u Char

227 symbolChar = P.oneOf opChars

231 symbolChar = P.oneOf opChars

228−

232+

229 parseStringLiteral :: P.Parsec String u String

233 parseStringLiteral :: P.Parsec String u String

230 parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

234 parseStringLiteral = blockString <|> PT.stringLiteral tokenParser

231− where

235+ where

232 delimeter = P.try (P.string "\"\"\"")

236 delimeter = P.try (P.string "\"\"\"")

233 blockString = delimeter >> P.manyTill P.anyChar delimeter

237 blockString = delimeter >> P.manyTill P.anyChar delimeter

234−

238+

235 parseNumber :: P.Parsec String u (Either Integer Double)

239 parseNumber :: P.Parsec String u (Either Integer Double)

236 parseNumber = (Right <$> P.try (PT.float tokenParser) <|>

240 parseNumber = (Right <$> P.try (PT.float tokenParser) <|>

237 Left <$> P.try (PT.natural tokenParser)) P.<?> "number"

241 Left <$> P.try (PT.natural tokenParser)) P.<?> "number"

@@ -261,10 +265,10 @@ tokenParser :: PT.GenTokenParser String u Identity

261tokenParser = PT.makeTokenParser langDef

265tokenParser = PT.makeTokenParser langDef

262

266

263type TokenParser a = P.Parsec [PositionedToken] ParseState a

267type TokenParser a = P.Parsec [PositionedToken] ParseState a

264−

268+

265anyToken :: TokenParser PositionedToken

269anyToken :: TokenParser PositionedToken

266anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just

270anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just

267−

271+

268token :: (Token -> Maybe a) -> TokenParser a

272token :: (Token -> Maybe a) -> TokenParser a

269token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

273token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)

270

274

@@ -347,7 +351,10 @@ semi :: TokenParser ()

347semi = match Semi

351semi = match Semi

348

352

349at :: TokenParser ()

353at :: TokenParser ()

350−at = match At

354+at = match At

355+

356+underscore :: TokenParser ()

357+underscore = match Underscore

351

358

352-- |

359-- |

353-- Parse zero or more values separated by semicolons

360-- Parse zero or more values separated by semicolons

@@ -408,13 +415,14 @@ uname' s = token go P.<?> show s

408 where

415 where

409 go (UName s') | s == s' = Just ()

416 go (UName s') | s == s' = Just ()

410 go _ = Nothing

417 go _ = Nothing

411−

418+

412symbol :: TokenParser String

419symbol :: TokenParser String

413symbol = token go P.<?> "symbol"

420symbol = token go P.<?> "symbol"

414 where

421 where

415 go (Symbol s) = Just s

422 go (Symbol s) = Just s

416 go Colon = Just ":"

423 go Colon = Just ":"

417 go LFatArrow = Just "<="

424 go LFatArrow = Just "<="

425+ go At = Just "@"

418 go _ = Nothing

426 go _ = Nothing

419

427

420symbol' :: String -> TokenParser ()

428symbol' :: String -> TokenParser ()

@@ -424,7 +432,7 @@ symbol' s = token go P.<?> show s

424 go Colon | s == ":" = Just ()

432 go Colon | s == ":" = Just ()

425 go LFatArrow | s == "<=" = Just ()

433 go LFatArrow | s == "<=" = Just ()

426 go _ = Nothing

434 go _ = Nothing

427−

435+

428stringLiteral :: TokenParser String

436stringLiteral :: TokenParser String

429stringLiteral = token go P.<?> "string literal"

437stringLiteral = token go P.<?> "string literal"

430 where

438 where

@@ -448,10 +456,10 @@ identifier = token go P.<?> "identifier"

448 where

456 where

449 go (LName s) | s `notElem` reservedPsNames = Just s

457 go (LName s) | s `notElem` reservedPsNames = Just s

450 go _ = Nothing

458 go _ = Nothing

451−

459+

452validModuleName :: String -> Bool

460validModuleName :: String -> Bool

453validModuleName s = not ('_' `elem` s)

461validModuleName s = not ('_' `elem` s)

454−

462+

455-- |

463-- |

456-- A list of purescript reserved identifiers

464-- A list of purescript reserved identifiers

457--

465--

@@ -479,7 +487,7 @@ reservedPsNames = [ "data"

479 , "in"

487 , "in"

480 , "where"

488 , "where"

481 ]

489 ]

482−

490+

483reservedTypeNames :: [String]

491reservedTypeNames :: [String]

484reservedTypeNames = [ "forall", "where" ]

492reservedTypeNames = [ "forall", "where" ]

485

493

@@ -488,4 +496,4 @@ reservedTypeNames = [ "forall", "where" ]

488--

496--

489opChars :: [Char]

497opChars :: [Char]

490opChars = ":!#$%&*+./<=>?@\\^|-~"

498opChars = ":!#$%&*+./<=>?@\\^|-~"

491−

499+

src/Language/PureScript/Parser/Types.hs+1−1

@@ -45,7 +45,7 @@ parseObject :: TokenParser Type

45parseObject = braces $ TypeApp tyObject <$> parseRow

45parseObject = braces $ TypeApp tyObject <$> parseRow

46

46

47parseTypeWildcard :: TokenParser Type

47parseTypeWildcard :: TokenParser Type

48−parseTypeWildcard = reserved "_" >> return TypeWildcard

48+parseTypeWildcard = underscore >> return TypeWildcard

49

49

50parseTypeVariable :: TokenParser Type

50parseTypeVariable :: TokenParser Type

51parseTypeVariable = do

51parseTypeVariable = do

src/Language/PureScript/Pretty/JS.hs+4−4

@@ -135,16 +135,16 @@ literals = mkPattern' match

135 commentLines :: Comment -> [String]

135 commentLines :: Comment -> [String]

136 commentLines (LineComment s) = [s]

136 commentLines (LineComment s) = [s]

137 commentLines (BlockComment s) = lines s

137 commentLines (BlockComment s) = lines s

138−

138+

139− asLine :: String -> StateT PrinterState Maybe String

139+ asLine :: String -> StateT PrinterState Maybe String

140 asLine s = do

140 asLine s = do

141 i <- currentIndent

141 i <- currentIndent

142 return $ i ++ " * " ++ removeComments s ++ "\n"

142 return $ i ++ " * " ++ removeComments s ++ "\n"

143−

143+

144 removeComments :: String -> String

144 removeComments :: String -> String

145 removeComments ('*' : '/' : s) = removeComments s

145 removeComments ('*' : '/' : s) = removeComments s

146 removeComments (c : s) = c : removeComments s

146 removeComments (c : s) = c : removeComments s

147−

147+

148 removeComments [] = []

148 removeComments [] = []

149 match (JSRaw js) = return js

149 match (JSRaw js) = return js

150 match _ = mzero

150 match _ = mzero

src/Language/PureScript/Pretty/Types.hs+1−1

@@ -34,7 +34,7 @@ import Language.PureScript.Environment

34typeLiterals :: Pattern () Type String

34typeLiterals :: Pattern () Type String

35typeLiterals = mkPattern match

35typeLiterals = mkPattern match

36 where

36 where

37− match TypeWildcard = Just "_"

37+ match TypeWildcard = Just "_"

38 match (TypeVar var) = Just var

38 match (TypeVar var) = Just var

39 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

39 match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

40 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

40 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

src/Language/PureScript/Pretty/Values.hs+36−27

@@ -21,12 +21,13 @@ module Language.PureScript.Pretty.Values (

21import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

22import Data.List (intercalate)

22import Data.List (intercalate)

23

23

24−import Control.Arrow ((<+>), runKleisli)

24+import Control.Arrow ((<+>), runKleisli, second)

25import Control.PatternArrows

25import Control.PatternArrows

26import Control.Monad.State

26import Control.Monad.State

27import Control.Applicative

27import Control.Applicative

28

28

29import Language.PureScript.AST

29import Language.PureScript.AST

30+import Language.PureScript.Names

30import Language.PureScript.Pretty.Common

31import Language.PureScript.Pretty.Common

31import Language.PureScript.Pretty.Types (prettyPrintType)

32import Language.PureScript.Pretty.Types (prettyPrintType)

32

33

@@ -38,33 +39,28 @@ literals = mkPattern' match

38 match (StringLiteral s) = return $ show s

39 match (StringLiteral s) = return $ show s

39 match (BooleanLiteral True) = return "true"

40 match (BooleanLiteral True) = return "true"

40 match (BooleanLiteral False) = return "false"

41 match (BooleanLiteral False) = return "false"

41− match (ArrayLiteral xs) = fmap concat $ sequence

42+ match (ArrayLiteral xs) = concat <$> sequence

42 [ return "[ "

43 [ return "[ "

43 , withIndent $ prettyPrintMany prettyPrintValue' xs

44 , withIndent $ prettyPrintMany prettyPrintValue' xs

44 , return " ]"

45 , return " ]"

45 ]

46 ]

46− match (ObjectLiteral []) = return "{}"

47+ match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps

47− match (ObjectLiteral ps) = fmap concat $ sequence

48+ match (ObjectConstructor ps) = prettyPrintObject' ps

48− [ return "{\n"

49+ match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"

49− , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

50− , return "\n"

51− , currentIndent

52− , return "}"

53− ]

54− match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence

50+ match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence

55− [ return ((show className) ++ "(\n")

51+ [ return (show className ++ "(\n")

56 , match ps

52 , match ps

57 , return ")"

53 , return ")"

58 ]

54 ]

59 match (Constructor name) = return $ show name

55 match (Constructor name) = return $ show name

60− match (Case values binders) = fmap concat $ sequence

56+ match (Case values binders) = concat <$> sequence

61 [ return "case "

57 [ return "case "

62 , unwords <$> forM values prettyPrintValue'

58 , unwords <$> forM values prettyPrintValue'

63 , return " of\n"

59 , return " of\n"

64 , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

60 , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

65 , currentIndent

61 , currentIndent

66 ]

62 ]

67− match (Let ds val) = fmap concat $ sequence

63+ match (Let ds val) = concat <$> sequence

68 [ return "let\n"

64 [ return "let\n"

69 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

65 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

70 , return "\n"

66 , return "\n"

@@ -73,11 +69,13 @@ literals = mkPattern' match

73 , prettyPrintValue' val

69 , prettyPrintValue' val

74 ]

70 ]

75 match (Var ident) = return $ show ident

71 match (Var ident) = return $ show ident

76− match (Do els) = fmap concat $ sequence

72+ match (Do els) = concat <$> sequence

77 [ return "do "

73 [ return "do "

78 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

74 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

79 , currentIndent

75 , currentIndent

80 ]

76 ]

77+ match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"

78+ match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"

81 match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

79 match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

82 match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

80 match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

83 match (TypedValue _ val _) = prettyPrintValue' val

81 match (TypedValue _ val _) = prettyPrintValue' val

@@ -86,7 +84,7 @@ literals = mkPattern' match

86

84

87prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

85prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

88prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

86prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

89−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence

87+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence

90 [ return $ show ident ++ " = "

88 [ return $ show ident ++ " = "

91 , prettyPrintValue' val

89 , prettyPrintValue' val

92 ]

90 ]

@@ -95,7 +93,7 @@ prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

95

93

96prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

94prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

97prettyPrintCaseAlternative (CaseAlternative binders result) =

95prettyPrintCaseAlternative (CaseAlternative binders result) =

98− fmap concat $ sequence

96+ concat <$> sequence

99 [ intercalate ", " <$> forM binders prettyPrintBinder'

97 [ intercalate ", " <$> forM binders prettyPrintBinder'

100 , prettyPrintResult result

98 , prettyPrintResult result

101 ]

99 ]

@@ -104,7 +102,7 @@ prettyPrintCaseAlternative (CaseAlternative binders result) =

104 prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

102 prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

105

103

106 prettyPrintGuardedValue (grd, val) =

104 prettyPrintGuardedValue (grd, val) =

107− fmap concat $ sequence

105+ concat <$> sequence

108 [ return "| "

106 [ return "| "

109 , prettyPrintValue' grd

107 , prettyPrintValue' grd

110 , return " -> "

108 , return " -> "

@@ -116,18 +114,28 @@ prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe S

116prettyPrintDoNotationElement (DoNotationValue val) =

114prettyPrintDoNotationElement (DoNotationValue val) =

117 prettyPrintValue' val

115 prettyPrintValue' val

118prettyPrintDoNotationElement (DoNotationBind binder val) =

116prettyPrintDoNotationElement (DoNotationBind binder val) =

119− fmap concat $ sequence

117+ concat <$> sequence

120 [ prettyPrintBinder' binder

118 [ prettyPrintBinder' binder

121 , return " <- "

119 , return " <- "

122 , prettyPrintValue' val

120 , prettyPrintValue' val

123 ]

121 ]

124prettyPrintDoNotationElement (DoNotationLet ds) =

122prettyPrintDoNotationElement (DoNotationLet ds) =

125− fmap concat $ sequence

123+ concat <$> sequence

126 [ return "let "

124 [ return "let "

127 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

125 , withIndent $ prettyPrintMany prettyPrintDeclaration ds

128 ]

126 ]

129prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

127prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

130

128

129+prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String

130+prettyPrintObject' [] = return "{}"

131+prettyPrintObject' ps = concat <$> sequence

132+ [ return "{\n"

133+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

134+ , return "\n"

135+ , currentIndent

136+ , return "}"

137+ ]

138+

131ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

139ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

132ifThenElse = mkPattern match

140ifThenElse = mkPattern match

133 where

141 where

@@ -144,6 +152,7 @@ objectUpdate :: Pattern PrinterState Expr ([String], Expr)

144objectUpdate = mkPattern match

152objectUpdate = mkPattern match

145 where

153 where

146 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

154 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

155+ match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)

147 match _ = Nothing

156 match _ = Nothing

148

157

149app :: Pattern PrinterState Expr (String, Expr)

158app :: Pattern PrinterState Expr (String, Expr)

@@ -188,17 +197,17 @@ prettyPrintBinderAtom = mkPattern' match

188 match (BooleanBinder True) = return "true"

197 match (BooleanBinder True) = return "true"

189 match (BooleanBinder False) = return "false"

198 match (BooleanBinder False) = return "false"

190 match (VarBinder ident) = return $ show ident

199 match (VarBinder ident) = return $ show ident

191− match (ConstructorBinder ctor args) = fmap concat $ sequence

200+ match (ConstructorBinder ctor args) = concat <$> sequence

192 [ return $ show ctor ++ " "

201 [ return $ show ctor ++ " "

193 , unwords <$> forM args match

202 , unwords <$> forM args match

194 ]

203 ]

195− match (ObjectBinder bs) = fmap concat $ sequence

204+ match (ObjectBinder bs) = concat <$> sequence

196 [ return "{\n"

205 [ return "{\n"

197 , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs

206 , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs

198 , currentIndent

207 , currentIndent

199 , return "}"

208 , return "}"

200 ]

209 ]

201− match (ArrayBinder bs) = fmap concat $ sequence

210+ match (ArrayBinder bs) = concat <$> sequence

202 [ return "["

211 [ return "["

203 , unwords <$> mapM prettyPrintBinder' bs

212 , unwords <$> mapM prettyPrintBinder' bs

204 , return "]"

213 , return "]"

@@ -229,13 +238,13 @@ matchConsBinder = mkPattern match'

229 match' _ = Nothing

238 match' _ = Nothing

230

239

231prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String

240prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String

232−prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence

241+prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence

233 [ return $ prettyPrintObjectKey key ++ ": "

242 [ return $ prettyPrintObjectKey key ++ ": "

234 , prettyPrintBinder' binder

243 , prettyPrintBinder' binder

235 ]

244 ]

236

245

237−prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String

246+prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String

238−prettyPrintObjectProperty (key, value) = fmap concat $ sequence

247+prettyPrintObjectProperty (key, value) = concat <$> sequence

239 [ return $ prettyPrintObjectKey key ++ ": "

248 [ return $ prettyPrintObjectKey key ++ ": "

240− , prettyPrintValue' value

249+ , maybe (pure "_") prettyPrintValue' value

241 ]

250 ]

src/Language/PureScript/Sugar.hs+19−10

@@ -23,20 +23,23 @@ import Language.PureScript.AST

23import Language.PureScript.Errors

23import Language.PureScript.Errors

24import Language.PureScript.Supply

24import Language.PureScript.Supply

25

25

26−import Language.PureScript.Sugar.Operators as S

27−import Language.PureScript.Sugar.DoNotation as S

28−import Language.PureScript.Sugar.CaseDeclarations as S

29−import Language.PureScript.Sugar.TypeDeclarations as S

30import Language.PureScript.Sugar.BindingGroups as S

26import Language.PureScript.Sugar.BindingGroups as S

31−import Language.PureScript.Sugar.TypeClasses as S

27+import Language.PureScript.Sugar.CaseDeclarations as S

28+import Language.PureScript.Sugar.DoNotation as S

32import Language.PureScript.Sugar.Names as S

29import Language.PureScript.Sugar.Names as S

30+import Language.PureScript.Sugar.ObjectWildcards as S

31+import Language.PureScript.Sugar.Operators as S

32+import Language.PureScript.Sugar.TypeClasses as S

33+import Language.PureScript.Sugar.TypeDeclarations as S

33

34

34-- |

35-- |

35-- The desugaring pipeline proceeds as follows:

36-- The desugaring pipeline proceeds as follows:

36--

37--

37−-- * Introduce type synonyms for type class dictionaries

38+-- * Remove signed literals in favour of `negate` applications

38--

39--

39−-- * Rebracket user-defined binary operators

40+-- * Desugar object literals with wildcards into lambdas

41+--

42+-- * Desugar operator sections

40--

43--

41-- * Desugar do-notation using the @Prelude.Monad@ type class

44-- * Desugar do-notation using the @Prelude.Monad@ type class

42--

45--

@@ -44,13 +47,19 @@ import Language.PureScript.Sugar.Names as S

44--

47--

45-- * Desugar type declarations into value declarations with explicit type annotations

48-- * Desugar type declarations into value declarations with explicit type annotations

46--

49--

47−-- * Group mutually recursive value and data declarations into binding groups.

48−--

49-- * Qualify any unqualified names and types

50-- * Qualify any unqualified names and types

50--

51--

52+-- * Rebracket user-defined binary operators

53+--

54+-- * Introduce type synonyms for type class dictionaries

55+--

56+-- * Group mutually recursive value and data declarations into binding groups.

57+--

51desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

58desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]

52desugar = map removeSignedLiterals

59desugar = map removeSignedLiterals

60+ >>> mapM desugarObjectConstructors

61+ >=> mapM desugarOperatorSections

53− >>> mapM desugarDoModule

62+ >=> mapM desugarDoModule

54 >=> desugarCasesModule

63 >=> desugarCasesModule

55 >=> lift . (desugarTypeDeclarationsModule

64 >=> lift . (desugarTypeDeclarationsModule

56 >=> desugarImports

65 >=> desugarImports

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -52,12 +52,12 @@ createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declara

52createBindingGroups moduleName = mapM f <=< handleDecls

52createBindingGroups moduleName = mapM f <=< handleDecls

53

53

54 where

54 where

55− (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

55+ (f, _, _) = everywhereOnValuesTopDownM return handleExprs return

56−

56+

57 handleExprs :: Expr -> Either ErrorStack Expr

57 handleExprs :: Expr -> Either ErrorStack Expr

58 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

58 handleExprs (Let ds val) = flip Let val <$> handleDecls ds

59 handleExprs other = return other

59 handleExprs other = return other

60−

60+

61 -- |

61 -- |

62 -- Replace all sets of mutually-recursive declarations with binding groups

62 -- Replace all sets of mutually-recursive declarations with binding groups

63 --

63 --

src/Language/PureScript/Sugar/Names.hs+41−15

@@ -54,8 +54,8 @@ data Exports = Exports

54 , exportedTypeClasses :: [ProperName]

54 , exportedTypeClasses :: [ProperName]

55 -- |

55 -- |

56 -- The values exported from each module

56 -- The values exported from each module

57− , exportedValues :: [Ident]

58 --

57 --

58+ , exportedValues :: [Ident]

59 } deriving (Show)

59 } deriving (Show)

60

60

61-- |

61-- |

@@ -105,15 +105,26 @@ addEmptyModule env name =

105--

105--

106addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment

106addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment

107addType env mn name dctors = updateExportedModule env mn $ \m -> do

107addType env mn name dctors = updateExportedModule env mn $ \m -> do

108− types' <- addExport (exportedTypes m) (name, dctors)

108+ let exTypes = exportedTypes m

109+ let exDctors = snd `concatMap` exTypes

110+ let exClasses = exportedTypeClasses m

111+ when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name

112+ when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name

113+ forM_ dctors $ \dctor -> do

114+ when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor

115+ when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor

109− return $ m { exportedTypes = types' }

116+ return $ m { exportedTypes = (name, dctors) : exTypes }

110

117

111-- |

118-- |

112-- Adds a class to the export environment.

119-- Adds a class to the export environment.

113--

120--

114addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment

121addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment

115addTypeClass env mn name = updateExportedModule env mn $ \m -> do

122addTypeClass env mn name = updateExportedModule env mn $ \m -> do

123+ let exTypes = exportedTypes m

124+ let exDctors = snd `concatMap` exTypes

125+ when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name

126+ when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name

116− classes <- addExport (exportedTypeClasses m) name

127+ classes <- addExport "type class" (exportedTypeClasses m) name

117 return $ m { exportedTypeClasses = classes }

128 return $ m { exportedTypeClasses = classes }

118

129

119-- |

130-- |

@@ -121,17 +132,17 @@ addTypeClass env mn name = updateExportedModule env mn $ \m -> do

121--

132--

122addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment

133addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment

123addValue env mn name = updateExportedModule env mn $ \m -> do

134addValue env mn name = updateExportedModule env mn $ \m -> do

124− values <- addExport (exportedValues m) name

135+ values <- addExport "value" (exportedValues m) name

125 return $ m { exportedValues = values }

136 return $ m { exportedValues = values }

126

137

127-- |

138-- |

128-- Adds an entry to a list of exports unless it is already present, in which case an error is

139-- Adds an entry to a list of exports unless it is already present, in which case an error is

129-- returned.

140-- returned.

130--

141--

131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]

142+addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]

132−addExport exports name =

143+addExport what exports name =

133 if name `elem` exports

144 if name `elem` exports

134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing

145+ then throwMultipleDefError what name

135 else return $ name : exports

146 else return $ name : exports

136

147

137-- |

148-- |

@@ -219,17 +230,16 @@ renameInModule imports exports (Module mn decls exps) =

219 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)

230 updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)

220 updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)

231 updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)

221 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

232 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

222− updateValue (pos, bound) (Let ds val') =

233+ updateValue (pos, bound) (Let ds val') = do

223 let args = mapMaybe letBoundVariable ds

234 let args = mapMaybe letBoundVariable ds

235+ unless (length (nub args) == length args) $

236+ throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing

224− in return ((pos, args ++ bound), Let ds val')

237+ return ((pos, args ++ bound), Let ds val')

238+ where

225 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

239 updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

226 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

240 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

227 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

241 updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

228 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

242 (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

229− updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =

230− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

231− updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =

232− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)

233 updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

243 updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

234 updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

244 updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

235 updateValue s v = return (s, v)

245 updateValue s v = return (s, v)

@@ -324,7 +334,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) pri

324 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

334 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

325 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

335 addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

326 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

336 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

327− addDecl mn env (PositionedDeclaration _ _ d) = addDecl mn env d

337+ addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d

328 addDecl _ env _ = return env

338 addDecl _ env _ = return env

329

339

330-- |

340-- |

@@ -520,3 +530,19 @@ resolveImport currentModule importModule exps imps impQual =

520 if item `elem` exports

530 if item `elem` exports

521 then return item

531 then return item

522 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing

532 else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing

533+

534+-- |

535+-- Raises an error for when there is more than one definition for something.

536+--

537+throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b

538+throwMultipleDefError what name = throwError $

539+ mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing

540+

541+-- |

542+-- Raises an error for when there is a conflicting definition for something, for example, a type

543+-- class and data constructor of the same name.

544+--

545+throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b

546+throwConflictingDefError what1 what2 name = throwError $

547+ mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing

548+

src/Language/PureScript/Sugar/ObjectWildcards.hsnew file+61

@@ -0,0 +1,61 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.ObjectWildcards

4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.Sugar.ObjectWildcards (

16+ desugarObjectConstructors

17+) where

18+

19+import Control.Applicative

20+import Control.Arrow (second)

21+

22+import Data.List (partition)

23+import Data.Maybe (isJust, fromJust, catMaybes)

24+

25+import Language.PureScript.AST

26+import Language.PureScript.Errors

27+import Language.PureScript.Names

28+import Language.PureScript.Supply

29+

30+desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module

31+desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts

32+ where

33+

34+ desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

35+ (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return

36+

37+ desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr

38+ desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps

39+ desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps

40+ desugarExpr (ObjectUpdater Nothing ps) = do

41+ obj <- Ident <$> freshName

42+ Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps

43+ desugarExpr (ObjectGetter prop) = do

44+ arg <- Ident <$> freshName

45+ return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))

46+ desugarExpr e = return e

47+

48+ wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr

49+ wrapLambda mkVal ps =

50+ let (props, args) = partition (isJust . snd) ps

51+ in if null args

52+ then return . mkVal $ second fromJust `map` props

53+ else do

54+ (args', ps') <- unzip <$> mapM mkProp ps

55+ return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')

56+

57+ mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))

58+ mkProp (name, Just e) = return (Nothing, (name, e))

59+ mkProp (name, Nothing) = do

60+ arg <- Ident <$> freshName

61+ return (Just arg, (name, Var (Qualified Nothing arg)))

src/Language/PureScript/Sugar/Operators.hs+25−10

@@ -21,12 +21,14 @@

21

21

22module Language.PureScript.Sugar.Operators (

22module Language.PureScript.Sugar.Operators (

23 rebracket,

23 rebracket,

24− removeSignedLiterals

24+ removeSignedLiterals,

25+ desugarOperatorSections

25) where

26) where

26

27

27−import Language.PureScript.Names

28import Language.PureScript.AST

28import Language.PureScript.AST

29import Language.PureScript.Errors

29import Language.PureScript.Errors

30+import Language.PureScript.Names

31+import Language.PureScript.Supply

30

32

31import Control.Applicative

33import Control.Applicative

32import Control.Monad.State

34import Control.Monad.State

@@ -103,7 +105,7 @@ customOperatorTable fixities =

103 in

105 in

104 map (map (\(name, f, _, a) -> (name, f, a))) groups

106 map (map (\(name, f, _, a) -> (name, f, a))) groups

105

107

106−type Chain = [Either Expr (Qualified Ident)]

108+type Chain = [Either Expr Expr]

107

109

108matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr

110matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr

109matchOperators ops = parseChains

111matchOperators ops = parseChains

@@ -112,11 +114,11 @@ matchOperators ops = parseChains

112 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

114 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

113 parseChains other = return other

115 parseChains other = return other

114 extendChain :: Expr -> Chain

116 extendChain :: Expr -> Chain

115− extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

117+ extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r

116 extendChain other = [Left other]

118 extendChain other = [Left other]

117 bracketChain :: Chain -> Either ErrorStack Expr

119 bracketChain :: Chain -> Either ErrorStack Expr

118 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

120 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

119− opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

121+ opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]

120 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

122 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

121 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

123 ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]

122

124

@@ -134,17 +136,30 @@ parseValue = token (either Just (const Nothing)) P.<?> "expression"

134parseOp :: P.Parsec Chain () (Qualified Ident)

136parseOp :: P.Parsec Chain () (Qualified Ident)

135parseOp = token (either (const Nothing) fromOp) P.<?> "operator"

137parseOp = token (either (const Nothing) fromOp) P.<?> "operator"

136 where

138 where

137− fromOp q@(Qualified _ (Op _)) = Just q

139+ fromOp (Var q@(Qualified _ (Op _))) = Just q

138 fromOp _ = Nothing

140 fromOp _ = Nothing

139

141

140−parseTicks :: P.Parsec Chain () (Qualified Ident)

142+parseTicks :: P.Parsec Chain () Expr

141−parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"

143+parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"

142 where

144 where

143− fromOp q@(Qualified _ (Ident _)) = Just q

145+ fromOther (Var (Qualified _ (Op _))) = Nothing

144− fromOp _ = Nothing

146+ fromOther v = Just v

145

147

146matchOp :: Qualified Ident -> P.Parsec Chain () ()

148matchOp :: Qualified Ident -> P.Parsec Chain () ()

147matchOp op = do

149matchOp op = do

148 ident <- parseOp

150 ident <- parseOp

149 guard $ ident == op

151 guard $ ident == op

150

152

153+desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module

154+desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts

155+ where

156+

157+ goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration

158+ (goDecl, _, _) = everywhereOnValuesM return goExpr return

159+

160+ goExpr :: Expr -> SupplyT (Either ErrorStack) Expr

161+ goExpr (OperatorSection op (Left val)) = return $ App op val

162+ goExpr (OperatorSection op (Right val)) = do

163+ arg <- Ident <$> freshName

164+ return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val

165+ goExpr other = return other

src/Language/PureScript/TypeChecker.hs+1−1

@@ -90,7 +90,7 @@ addTypeClass moduleName pn args implies ds =

90

90

91addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

91addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

92addTypeClassDictionaries entries =

92addTypeClassDictionaries entries =

93− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]

93+ let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]

94 in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }

94 in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }

95

95

96checkDuplicateTypeArguments :: [String] -> Check ()

96checkDuplicateTypeArguments :: [String] -> Check ()

src/Language/PureScript/TypeChecker/Entailment.hs+23−3

@@ -20,6 +20,7 @@ module Language.PureScript.TypeChecker.Entailment (

20import Data.Function (on)

20import Data.Function (on)

21import Data.List

21import Data.List

22import Data.Maybe (maybeToList)

22import Data.Maybe (maybeToList)

23+import Data.Foldable (foldMap)

23import qualified Data.Map as M

24import qualified Data.Map as M

24

25

25import Control.Applicative

26import Control.Applicative

@@ -199,13 +200,32 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

199-- and return a substitution from type variables to types which makes the type heads unify.

200-- and return a substitution from type variables to types which makes the type heads unify.

200--

201--

201typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

202typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

202−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []

203+typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []

203−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

204+typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]

204typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

205typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []

205−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2

206+typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2

207+ <*> typeHeadsAreEqual m e t1 t2

206typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

208typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of

207 Left _ -> Nothing

209 Left _ -> Nothing

208 Right t1 -> typeHeadsAreEqual m e t1 t2

210 Right t1 -> typeHeadsAreEqual m e t1 t2

211+typeHeadsAreEqual _ _ REmpty REmpty = Just []

212+typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =

213+ let (s1, r1') = rowToList r1

214+ (s2, r2') = rowToList r2

215+

216+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

217+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

218+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

219+ in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int

220+ <*> go sd1 r1' sd2 r2'

221+ where

222+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]

223+ go [] REmpty [] REmpty = Just []

224+ go [] (TUnknown _) _ _ = Just []

225+ go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []

226+ go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []

227+ go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]

228+ go _ _ _ _ = Nothing

209typeHeadsAreEqual _ _ _ _ = Nothing

229typeHeadsAreEqual _ _ _ _ = Nothing

210

230

211-- |

231-- |

src/Language/PureScript/TypeChecker/Kinds.hs+69−42

@@ -14,19 +14,22 @@

14-----------------------------------------------------------------------------

14-----------------------------------------------------------------------------

15

15

16{-# OPTIONS_GHC -fno-warn-orphans #-}

16{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

17+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections #-}

18

18

19module Language.PureScript.TypeChecker.Kinds (

19module Language.PureScript.TypeChecker.Kinds (

20 kindOf,

20 kindOf,

21+ kindOfWithScopedVars,

21 kindsOf,

22 kindsOf,

22 kindsOfAll

23 kindsOfAll

23) where

24) where

24

25

25import Data.Maybe (fromMaybe)

26import Data.Maybe (fromMaybe)

26import Data.Monoid ((<>))

27import Data.Monoid ((<>))

28+

27import qualified Data.HashMap.Strict as H

29import qualified Data.HashMap.Strict as H

28import qualified Data.Map as M

30import qualified Data.Map as M

29

31

32+import Control.Arrow (second)

30import Control.Applicative

33import Control.Applicative

31import Control.Monad.Error

34import Control.Monad.Error

32import Control.Monad.State

35import Control.Monad.State

@@ -69,11 +72,19 @@ instance Unifiable Check Kind where

69-- Infer the kind of a single type

72-- Infer the kind of a single type

70--

73--

71kindOf :: ModuleName -> Type -> Check Kind

74kindOf :: ModuleName -> Type -> Check Kind

72−kindOf _ ty =

75+kindOf _ ty = fst <$> kindOfWithScopedVars ty

76+

77+-- |

78+-- Infer the kind of a single type, returning the kinds of any scoped type variables

79+--

80+kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])

81+kindOfWithScopedVars ty =

73 rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

82 rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $

74− fmap (starIfUnknown . tidyUp) . liftUnify $ infer ty

83+ fmap tidyUp . liftUnify $ infer ty

75 where

84 where

76− tidyUp (k, sub) = sub $? k

85+ tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)

86+ , map (second (starIfUnknown . (sub $?))) args

87+ )

77

88

78-- |

89-- |

79-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

90-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

@@ -125,7 +136,7 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

125--

136--

126solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind

137solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind

127solveTypes isData ts kargs tyCon = do

138solveTypes isData ts kargs tyCon = do

128− ks <- mapM infer ts

139+ ks <- mapM (fmap fst . infer) ts

129 when isData $ do

140 when isData $ do

130 tyCon =?= foldr FunKind Star kargs

141 tyCon =?= foldr FunKind Star kargs

131 forM_ ks $ \k -> k =?= Star

142 forM_ ks $ \k -> k =?= Star

@@ -145,48 +156,64 @@ starIfUnknown k = k

145-- |

156-- |

146-- Infer a kind for a type

157-- Infer a kind for a type

147--

158--

148−infer :: Type -> UnifyT Kind Check Kind

159+infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

149infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

160infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty

150

161

151−infer' :: Type -> UnifyT Kind Check Kind

162+infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])

152−infer' TypeWildcard = fresh

153−infer' (TypeVar v) = do

154− Just moduleName <- checkCurrentModule <$> get

155− UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

156−infer' c@(TypeConstructor v) = do

157− env <- liftCheck getEnv

158− case M.lookup v (types env) of

159− Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))

160− Just (kind, _) -> return kind

161−infer' (TypeApp t1 t2) = do

162− k0 <- fresh

163− k1 <- infer t1

164− k2 <- infer t2

165− k1 =?= FunKind k2 k0

166− return k0

167infer' (ForAll ident ty _) = do

163infer' (ForAll ident ty _) = do

168 k1 <- fresh

164 k1 <- fresh

169 Just moduleName <- checkCurrentModule <$> get

165 Just moduleName <- checkCurrentModule <$> get

170− k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty

166+ (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty

171 k2 =?= Star

167 k2 =?= Star

172− return Star

168+ return (Star, (ident, k1) : args)

173−infer' REmpty = do

174− k <- fresh

175− return $ Row k

176−infer' (RCons _ ty row) = do

177− k1 <- infer ty

178− k2 <- infer row

179− k2 =?= Row k1

180− return $ Row k1

181−infer' (ConstrainedType deps ty) = do

182− forM_ deps $ \(className, tys) -> do

183− _ <- infer $ foldl TypeApp (TypeConstructor className) tys

184− return ()

185− k <- infer ty

186− k =?= Star

187− return Star

188infer' (KindedType ty k) = do

169infer' (KindedType ty k) = do

189− k' <- infer ty

170+ (k', args) <- infer ty

190 k =?= k'

171 k =?= k'

191− return k'

172+ return (k', args)

173+infer' other = (, []) <$> go other

174+ where

175+ go :: Type -> UnifyT Kind Check Kind

176+ go (ForAll ident ty _) = do

177+ k1 <- fresh

178+ Just moduleName <- checkCurrentModule <$> get

179+ k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty

180+ k2 =?= Star

181+ return Star

182+ go (KindedType ty k) = do

183+ k' <- go ty

184+ k =?= k'

185+ return k'

186+ go TypeWildcard = fresh

187+ go (TypeVar v) = do

188+ Just moduleName <- checkCurrentModule <$> get

189+ UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

190+ go (Skolem v _ _) = do

191+ Just moduleName <- checkCurrentModule <$> get

192+ UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

193+ go c@(TypeConstructor v) = do

194+ env <- liftCheck getEnv

195+ case M.lookup v (types env) of

196+ Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))

197+ Just (kind, _) -> return kind

198+ go (TypeApp t1 t2) = do

199+ k0 <- fresh

200+ k1 <- go t1

201+ k2 <- go t2

202+ k1 =?= FunKind k2 k0

203+ return k0

204+ go REmpty = do

205+ k <- fresh

206+ return $ Row k

207+ go (RCons _ ty row) = do

208+ k1 <- go ty

209+ k2 <- go row

210+ k2 =?= Row k1

211+ return $ Row k1

212+ go (ConstrainedType deps ty) = do

213+ forM_ deps $ \(className, tys) -> do

214+ _ <- go $ foldl TypeApp (TypeConstructor className) tys

215+ return ()

216+ k <- go ty

217+ k =?= Star

218+ return Star

192−infer' _ = error "Invalid argument to infer"

219+ go _ = error "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Monad.hs+13−4

@@ -23,6 +23,7 @@ import qualified Data.Map as M

23

23

24import Control.Applicative

24import Control.Applicative

25import Control.Monad.Error

25import Control.Monad.Error

26+import Control.Monad.Reader.Class

26import Control.Monad.State

27import Control.Monad.State

27import Control.Monad.Unify

28import Control.Monad.Unify

28

29

@@ -56,6 +57,12 @@ bindTypes newNames action = do

56 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

57 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

57 return a

58 return a

58

59

60+-- |

61+-- Temporarily bind a collection of names to types

62+--

63+withScopedTypeVars :: (Functor m, MonadState CheckState m) => ModuleName -> [(String, Kind)] -> m a -> m a

64+withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks))

65+

59-- |

66-- |

60-- Temporarily make a collection of type class dictionaries available

67-- Temporarily make a collection of type class dictionaries available

61--

68--

@@ -188,14 +195,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

188-- |

195-- |

189-- Run a computation in the Check monad, starting with an empty @Environment@

196-- Run a computation in the Check monad, starting with an empty @Environment@

190--

197--

191−runCheck :: Options mode -> Check a -> Either String (a, Environment)

198+runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)

192−runCheck opts = runCheck' opts initEnvironment

199+runCheck = runCheck' initEnvironment

193

200

194-- |

201-- |

195-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

202-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

196--

203--

197−runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)

204+runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)

205+runCheck' env c = do

206+ verbose <- asks optionsVerboseErrors

198−runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do

207+ stringifyErrorStack verbose $ do

199 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

208 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

200 return (a, checkEnv s)

209 return (a, checkEnv s)

201

210

src/Language/PureScript/TypeChecker/Skolems.hs+1

@@ -71,6 +71,7 @@ skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr

71skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f

71skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f

72 where

72 where

73 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

73 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

74+ go (TypedValue check val ty) = TypedValue check val (skolemize ident sko scope ty)

74 go other = other

75 go other = other

75

76

76-- |

77-- |

src/Language/PureScript/TypeChecker/Types.hs+24−26

@@ -52,6 +52,7 @@ import Language.PureScript.Errors

52import Language.PureScript.Kinds

52import Language.PureScript.Kinds

53import Language.PureScript.Names

53import Language.PureScript.Names

54import Language.PureScript.Pretty

54import Language.PureScript.Pretty

55+import Language.PureScript.Traversals

55import Language.PureScript.TypeChecker.Entailment

56import Language.PureScript.TypeChecker.Entailment

56import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Monad

58import Language.PureScript.TypeChecker.Monad

@@ -128,16 +129,16 @@ typeDictionaryForBindingGroup moduleName vals = do

128 return (untyped, typed, dict, untypedDict)

129 return (untyped, typed, dict, untypedDict)

129

130

130checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))

131checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))

131−checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do

132+checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do

132 -- Replace type wildcards

133 -- Replace type wildcards

133 ty' <- replaceTypeWildcards ty

134 ty' <- replaceTypeWildcards ty

134 -- Kind check

135 -- Kind check

135− kind <- liftCheck $ kindOf moduleName ty

136+ (kind, args) <- liftCheck $ kindOfWithScopedVars ty

136− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

137+ checkTypeKind kind

137 -- Check the type with the new names in scope

138 -- Check the type with the new names in scope

138 ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'

139 ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'

139 val'' <- if checkType

140 val'' <- if checkType

140− then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''

141+ then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''

141 else return (TypedValue False val' ty'')

142 else return (TypedValue False val' ty'')

142 return (ident, (val'', ty''))

143 return (ident, (val'', ty''))

143

144

@@ -182,10 +183,8 @@ replaceTypeClassDictionaries mn =

182-- |

183-- |

183-- Check the kind of a type, failing if it is not of kind *.

184-- Check the kind of a type, failing if it is not of kind *.

184--

185--

185−checkTypeKind :: ModuleName -> Type -> UnifyT t Check ()

186+checkTypeKind :: Kind -> UnifyT t Check ()

186−checkTypeKind moduleName ty = do

187− kind <- liftCheck $ kindOf moduleName ty

188− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

187+checkTypeKind kind = guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

189

188

190-- |

189-- |

191-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

190-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns

@@ -271,8 +270,8 @@ infer' v@(Constructor c) = do

271 env <- getEnv

270 env <- getEnv

272 case M.lookup c (dataConstructors env) of

271 case M.lookup c (dataConstructors env) of

273 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

272 Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"

274− Just (_, _, ty, _) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

273+ Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty

275− return $ TypedValue True v ty'

274+ return $ TypedValue True v' ty'

276infer' (Case vals binders) = do

275infer' (Case vals binders) = do

277 ts <- mapM infer vals

276 ts <- mapM infer vals

278 ret <- fresh

277 ret <- fresh

@@ -292,9 +291,10 @@ infer' (SuperClassDictionary className tys) = do

292 return $ TypeClassDictionary False (className, tys) dicts

291 return $ TypeClassDictionary False (className, tys) dicts

293infer' (TypedValue checkType val ty) = do

292infer' (TypedValue checkType val ty) = do

294 Just moduleName <- checkCurrentModule <$> get

293 Just moduleName <- checkCurrentModule <$> get

295− checkTypeKind moduleName ty

294+ (kind, args) <- liftCheck $ kindOfWithScopedVars ty

295+ checkTypeKind kind

296 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

296 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

297− val' <- if checkType then check val ty' else return val

297+ val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val

298 return $ TypedValue True val' ty'

298 return $ TypedValue True val' ty'

299infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

299infer' (PositionedValue pos _ val) = rethrowWithPosition pos $ infer' val

300infer' _ = error "Invalid argument to infer"

300infer' _ = error "Invalid argument to infer"

@@ -303,10 +303,11 @@ inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Typ

303inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

303inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

304inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do

304inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do

305 Just moduleName <- checkCurrentModule <$> get

305 Just moduleName <- checkCurrentModule <$> get

306− checkTypeKind moduleName ty

306+ (kind, args) <- liftCheck $ kindOfWithScopedVars ty

307+ checkTypeKind kind

307 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

308 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)

308 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

309 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty

309− TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv

310+ TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv

310 bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

311 bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j

311inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

312inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do

312 valTy <- fresh

313 valTy <- fresh

@@ -506,14 +507,15 @@ check' (SuperClassDictionary className tys) _ = do

506 return $ TypeClassDictionary False (className, tys) dicts

507 return $ TypeClassDictionary False (className, tys) dicts

507check' (TypedValue checkType val ty1) ty2 = do

508check' (TypedValue checkType val ty1) ty2 = do

508 Just moduleName <- checkCurrentModule <$> get

509 Just moduleName <- checkCurrentModule <$> get

509− checkTypeKind moduleName ty1

510+ (kind, args) <- liftCheck $ kindOfWithScopedVars ty1

511+ checkTypeKind kind

510 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

512 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1

511 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

513 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2

512 val' <- subsumes (Just val) ty1' ty2'

514 val' <- subsumes (Just val) ty1' ty2'

513 case val' of

515 case val' of

514 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

516 Nothing -> throwError . strMsg $ "Unable to check type subsumption"

515 Just val'' -> do

517 Just val'' -> do

516− val''' <- if checkType then check val'' ty2' else return val''

518+ val''' <- if checkType then withScopedTypeVars moduleName args (check val'' ty2') else return val''

517 return $ TypedValue checkType (TypedValue True val''' ty1') ty2'

519 return $ TypedValue checkType (TypedValue True val''' ty1') ty2'

518check' (Case vals binders) ret = do

520check' (Case vals binders) ret = do

519 vals' <- mapM infer vals

521 vals' <- mapM infer vals

@@ -561,11 +563,11 @@ check' val ty | containsTypeSynonyms ty = do

561 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty

563 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty

562 check val ty'

564 check val ty'

563check' val kt@(KindedType ty kind) = do

565check' val kt@(KindedType ty kind) = do

564− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

566+ checkTypeKind kind

565 val' <- check' val ty

567 val' <- check' val ty

566 return $ TypedValue True val' kt

568 return $ TypedValue True val' kt

567check' (PositionedValue pos _ val) ty =

569check' (PositionedValue pos _ val) ty =

568− rethrowWithPosition pos $ check val ty

570+ rethrowWithPosition pos $ check' val ty

569check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

571check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

570

572

571containsTypeSynonyms :: Type -> Bool

573containsTypeSynonyms :: Type -> Bool

@@ -581,18 +583,14 @@ containsTypeSynonyms = everythingOnTypes (||) go where

581checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

583checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

582checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

584checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

583 go [] [] REmpty = return []

585 go [] [] REmpty = return []

584− go [] [] u@(TUnknown _) = do u =?= REmpty

586+ go [] [] u@(TUnknown _)

587+ | lax = return []

588+ | otherwise = do u =?= REmpty

585− return []

589+ return []

586 go [] [] Skolem{} | lax = return []

590 go [] [] Skolem{} | lax = return []

587 go [] ((p, _): _) _ | lax = return []

591 go [] ((p, _): _) _ | lax = return []

588 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

592 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

589 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

593 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

590− go ((p,v):ps') [] u@(TUnknown _) = do

591− v'@(TypedValue _ _ ty) <- infer v

592− rest <- fresh

593− u =?= RCons p ty rest

594− ps'' <- go ps' [] rest

595− return $ (p, v') : ps''

596 go ((p,v):ps') ts r =

594 go ((p,v):ps') ts r =

597 case lookup p ts of

595 case lookup p ts of

598 Nothing -> do

596 Nothing -> do

src/Language/PureScript/TypeChecker/Unify.hs+22−1

@@ -130,6 +130,10 @@ unifyRows r1 r2 =

130 rest <- fresh

130 rest <- fresh

131 u1 =:= rowFromList (sd2, rest)

131 u1 =:= rowFromList (sd2, rest)

132 u2 =:= rowFromList (sd1, rest)

132 u2 =:= rowFromList (sd1, rest)

133+ unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do

134+ r1' <- expandTypeSynonym name $ args

135+ unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))

136+ unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'

133 unifyRows' [] REmpty [] REmpty = return ()

137 unifyRows' [] REmpty [] REmpty = return ()

134 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

138 unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()

135 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

139 unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()

@@ -149,6 +153,23 @@ unifiesWith e (SaturatedTypeSynonym name args) t2 =

149 Left _ -> False

153 Left _ -> False

150 Right t1 -> unifiesWith e t1 t2

154 Right t1 -> unifiesWith e t1 t2

151unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1

155unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1

156+unifiesWith _ REmpty REmpty = True

157+unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =

158+ let (s1, r1') = rowToList r1

159+ (s2, r2') = rowToList r2

160+

161+ int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

162+ sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

163+ sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

164+ in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2'

165+ where

166+ go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

167+ go [] REmpty [] REmpty = True

168+ go [] (TypeVar v1) [] (TypeVar v2) = v1 == v2

169+ go [] (Skolem _ s1 _) [] (Skolem _ s2 _) = s1 == s2

170+ go _ (TUnknown _) _ _ = True

171+ go _ _ _ (TUnknown _) = True

172+ go _ _ _ _ = False

152unifiesWith _ _ _ = False

173unifiesWith _ _ _ = False

153

174

154-- |

175-- |

@@ -158,7 +179,7 @@ replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type

158replaceVarWithUnknown ident ty = do

179replaceVarWithUnknown ident ty = do

159 tu <- fresh

180 tu <- fresh

160 return $ replaceTypeVars ident tu ty

181 return $ replaceTypeVars ident tu ty

161−

182+

162-- |

183-- |

163-- Replace type wildcards with unknowns

184-- Replace type wildcards with unknowns

164--

185--

tests/Main.hs+5−4

@@ -22,6 +22,7 @@ import Data.List (isSuffixOf)

22import Data.Traversable (traverse)

22import Data.Traversable (traverse)

23import Control.Monad

23import Control.Monad

24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

25+import Control.Monad.Reader (runReaderT)

25import Control.Applicative

26import Control.Applicative

26import System.Exit

27import System.Exit

27import System.Process

28import System.Process

@@ -35,10 +36,10 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do

35 return (inputFile, text)

36 return (inputFile, text)

36

37

37loadPrelude :: Either String (String, String, P.Environment)

38loadPrelude :: Either String (String, String, P.Environment)

38−loadPrelude =

39+loadPrelude =

39 case P.parseModulesFromFiles id [("", P.prelude)] of

40 case P.parseModulesFromFiles id [("", P.prelude)] of

40 Left parseError -> Left (show parseError)

41 Left parseError -> Left (show parseError)

41− Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []

42+ Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }

42

43

43compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))

44compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))

44compile opts inputFiles = do

45compile opts inputFiles = do

@@ -46,7 +47,7 @@ compile opts inputFiles = do

46 case modules of

47 case modules of

47 Left parseError ->

48 Left parseError ->

48 return (Left $ show parseError)

49 return (Left $ show parseError)

49− Right ms -> return $ P.compile opts (map snd ms) []

50+ Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts

50

51

51assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

52assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

52assert preludeExterns opts inputFile f = do

53assert preludeExterns opts inputFile f = do

@@ -85,7 +86,7 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

85

86

86main :: IO ()

87main :: IO ()

87main = do

88main = do

88− putStrLn "Compiling Prelude"

89+ putStrLn "Compiling Prelude"

89 case loadPrelude of

90 case loadPrelude of

90 Left err -> putStrLn err >> exitFailure

91 Left err -> putStrLn err >> exitFailure

91 Right (preludeJs, exts, _) -> do

92 Right (preludeJs, exts, _) -> do