7de366c · rowtype-yoga/purescript-native

RELEASE-0.5.md+4−2

compare with golang

unifiedsplit

@@ -2,7 +2,7 @@

2

3## Breaking Changes

4

5−-

5+- Support for blocks has been removed. (paf31)

6

7### New Features

8

@@ -11,10 +11,12 @@

11### Enhancements

12

13- Pretty printing for row types was improved (garyb)

14+- Module names can now contain `.` (garyb)

15+- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31)

14

16

15### Bug Fixes

17### Bug Fixes

16

18

17−-

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

18

20

19### Libraries

21### Libraries

20

22

docgen/Main.hs+2−2

@@ -59,8 +59,8 @@ renderModules ms = do

59 mapM_ renderModule ms

60

61renderModule :: P.Module -> Docs

62−renderModule (P.Module (P.ProperName moduleName) ds) = do

62+renderModule (P.Module moduleName ds) = do

63− headerLevel 2 $ "Module " ++ moduleName

63+ headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)

64 spacer

65 headerLevel 3 "Types"

66 spacer

docs/source/blocks.rstdeleted−90

@@ -1,90 +0,0 @@

1−Blocks

2−======

3−

4−Blocks are collections of statements wrapped in braces ``{ ... }``. Blocks must return a value of the same type on every branch of execution.

5−

6−The following types of statement are supported:

7−

8−- Variable introduction

9−- Variable assignment

10−- For loops

11−- While loops

12−- If-Then-Else statements

13−

14−Here is an example of a power function defined using a block::

15−

16− pow n p = {

17− var m = n;

18− for (i <- 0 until p) {

19− m = m * n;

20− }

21− return m;

22− }

23−

24−Blocks enable local mutation of their variables, but mutation is not allowed in general. The type system prevents mutable variables from escaping their scope.

25−

26−That is, while the example above is valid, the following does not compile::

27−

28− incr n = {

29− n = n + 1;

30− return n;

31− }

32−

33−The variable ``n`` is not mutable, and so the assignment in the first line of the block is not allowed.

34−

35−This function can be rewritten as follows::

36−

37− incr n = {

38− var m = n;

39− m = m + 1;

40− return m;

41− }

42−

43−For Loops

44−---------

45−

46−For loops iterate over a range of numbers::

47−

48− total = {

49− var n = 0;

50− for (i <- 0 until 10) {

51− n = n + i;

52− }

53− return n;

54− }

55−

56−The bounds `0` and `10` are inclusive and exclusive respectively.

57−

58−While Loops

59−------------

60−

61−While loops repeat a set of statements while a boolean expression evaluates to ``true``::

62−

63− log2 n = {

64− var count = 0;

65− var m = n;

66− while (m > 1) {

67− m = m / 2;

68− count = count + 1;

69− }

70− return count;

71− }

72−

73−If-Then-Else Statements

74−-----------------------

75−

76−Else branches are optional, and may contain further ``if`` statements, just as in Javascript::

77−

78− collatz n = {

79− var count = 0;

80− var m = n;

81− while (m > 1) {

82− if (m % 2 == 0) {

83− m = m / 2;

84− } else {

85− m = m * 3 + 1;

86− }

87− count = count + 1;

88− }

89− return count;

90− }

docs/source/index.rst−1

@@ -15,7 +15,6 @@ Contents:

15 types

16 kinds

17 syntax

18− blocks

19 typeclasses

18 typeclasses

20 patterns

19 patterns

21 modules

20 modules

docs/source/intro.rst+2−2

@@ -8,7 +8,7 @@ PureScript is a small strongly, statically typed compile-to-JS language with a n

8- Support for basic Javascript types

9- Extensible records

10- Extensible effects

11−- Type-safe blocks with for/while/assignment etc.

11+- Optimizer rules for generation of efficient Javascript

12- Pattern matching

13- Simple FFI

14- Modules

@@ -64,7 +64,7 @@ I was looking for a simple functional language which would compile to JavaScript

64

65I didn't find exactly what I was looking for, so I wrote PureScript. It doesn't have everything right now, but it should serve as a simple core on which to develop new ideas.

66

67−PureScript is *not* designed to be a general-purpose programming language. The primary use case is as a generator for purely-functional core libraries, with the main application code written in another language.

67+PureScript was originally designed to implement purely functional core logic. However, recent additions to the compiler and libraries now also make it a good option for general-purpose programming.

68

69PureScript can also be seen as a trade-off between a theoretically ideal language and one which generates reasonably high performance code.

70

examples/passing/Assign.pursdeleted−38

@@ -1,38 +0,0 @@

1−module Assign where

2−

3− import Prelude

4−

5− sum = \n -> {

6− var x = 0;

7− for (i <- 0 until n) {

8− x = x + i;

9− }

10− return x;

11− }

12−

13− arr = [1, 2]

14−

15− foo = {

16− var x = 0; -- mutable

17− var y = 1; -- immutable

18−

19− -- x should not be inlined since x is mutable

20− while (x < 10) {

21− x = x + 1;

22− }

23−

24− var z1 = arr !! x; -- immutable

25− var b = (\x -> z1) 2; -- z1 should not be inlined since x is bound

26−

27− var z2 = arr !! x; -- immutable

28− var z3 = arr !! x; -- immutable

29− var a = (\z2 -> z2) 2; -- z3 should not be inlined since z2 is bound

30−

31− -- y should be inlined

32− -- z3 should be inlined

33− return x + y + z1 + z2 + z3 + a + b;

34− }

35−

36−module Main where

37−

38−main = Trace.trace "Done"

examples/passing/Collatz.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

2+

3+import Prelude

4+import Eff

5+import ST

6+

7+collatz :: Number -> Number

8+collatz n = runPure (runST (do

9+ r <- newSTRef n

10+ count <- newSTRef 0

11+ untilE $ do

12+ modifySTRef count $ (+) 1

13+ m <- readSTRef r

14+ writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1

15+ return $ m == 1

16+ readSTRef count))

17+

18+main = Trace.print $ collatz 1

examples/passing/DottedModules.pursnew file+20

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

1+module Some.Module.Name where

2+

3+ class Foo a where

4+ foo :: a -> a

5+

6+ data Text = Text String

7+

8+ x = Text "Done"

9+

10+module Main where

11+

12+ import Prelude

13+ import Some.Module.Name

14+

15+ instance Some.Module.Name.Foo String where

16+ foo s = s

17+

18+ unwrap (Text x) = x

19+

20+ main = Trace.print $ foo $ unwrap x

examples/passing/IfThenElse.pursdeleted−42

@@ -1,42 +0,0 @@

1−module IfThenElse where

2−

3− import Prelude

4−

5− testIf =

6− {

7− var x = 0;

8− if (x == 0) {

9− x = x + 1;

10− }

11− return x;

12− }

13−

14− testIfElse =

15− {

16− var x = 0;

17− if (x == 0) {

18− x = x + 1;

19− } else {

20− x = x - 1;

21− }

22− return x;

23− }

24−

25− testIfElseIf = \x ->

26− {

27− var y = x;

28− while (y > 1) {

29− if (y % 3 == 0) {

30− y = y / 3;

31− } else if (y % 3 == 1) {

32− y = (y - 1) % 3;

33− } else {

34− y = y * 4 + 1;

35− }

36− }

37− return y;

38− }

39−

40−module Main where

41−

42−main = Trace.trace "Done"

examples/passing/JSReserved.purs+4−26

@@ -5,30 +5,10 @@ module JSReserved where

5 yield = 0

6 member = 1

7

8− this = {

9− var function = 0;

10− for (i <- 0 until 10) {

11− function = function + i;

12− }

13− return function;

14− }

15−

16− catch = {

17− var for = 0;

18− while (for > 0) {

19− for = for - 1;

20− }

21− return for;

22− }

23−

24− instanceof = {

25− var var = 1;

26− var = var + 1;

27− return var;

28− }

29−

30 public = \return -> return

8 public = \return -> return

31

9

10+ this catch = catch

11+

32module Main where

12module Main where

33

13

34 import Prelude

14 import Prelude

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

37

17

38 main = Trace.print [ yield

18 main = Trace.print [ yield

39 , member

19 , member

40− , this

20+ , this 1

41− , catch

42− , instanceof

43− , public 1 ]

21+ , public 1 ]

examples/passing/Let.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

2+

3+import Prelude

4+import Eff

5+

6+test1 x = let y = x + 1 in y

7+

8+test2 x y =

9+ let x' = x + 1 in

10+ let y' = y + 1 in

11+ x' + y'

12+

13+test3 x = let 1 = x in 2

14+

15+main = do

16+ Trace.print (test1 1)

17+ Trace.print (test2 1 2)

18+ Trace.print (test3 1)

examples/passing/STArray.pursnew file+23

@@ -0,0 +1,23 @@

1+module Main where

2+

3+import Prelude

4+import Eff

5+import ST

6+import Arrays

7+

8+test = runSTArray (do

9+ a <- newSTArray 2 0

10+ pokeSTArray a 0 1

11+ pokeSTArray a 1 2

12+ return a)

13+

14+fromTo' lo hi _ arr | lo > hi = return arr

15+fromTo' lo hi i arr = do

16+ pokeSTArray arr i lo

17+ fromTo' (lo + 1) hi (i + 1) arr

18+

19+fromTo lo hi = runSTArray (do

20+ arr <- newSTArray (hi - lo + 1) 0

21+ fromTo' lo hi 0 arr)

22+

23+main = Trace.print $ runPure (fromTo 10 20)

examples/passing/TailCall.purs+4−1

@@ -14,4 +14,7 @@ notATailCall = \x ->

14

15module Main where

16

17+import Prelude

18+import TailCall

19+

17−main = Trace.trace "Done"

20+main = Trace.print (test 0 [1, 2, 3])

examples/passing/TypeDecl.purs+4−10

@@ -1,19 +1,13 @@

1module TypeDecl where

2

3− id :: forall a. (a) -> a

3+ import Prelude

4− id = \x -> x

5

4

6 k :: String -> Number -> String

5 k :: String -> Number -> String

7− k = \x -> \y -> x

6+ k x y = x

8

7

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

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

10− iterate = \n -> \f -> \a -> {

9+ iterate 0 f a = a

11− var result = a;

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

12− for (i <- 0 until n) {

13− result = f result;

14− }

15− return result;

16− }

17

11

18module Main where

12module Main where

19

13

examples/passing/TypeSynonyms.purs+2−7

@@ -8,12 +8,7 @@ module TypeSynonyms where

8 composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

9 composeLenses = \l1 -> \l2 ->

10 { get: \a -> l2.get (l1.get a)

11− , set: \a -> \c ->

11+ , set: \a c -> l1.set a (l2.set (l1.get a) c)

12− {

13− var b = l1.get a;

14− var b1 = l2.set b c;

15− return l1.set a b1;

16− }

17 }

12 }

18

13

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

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

@@ -21,7 +16,7 @@ module TypeSynonyms where

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

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

22 fst =

17 fst =

23 { get: \p -> p.fst

18 { get: \p -> p.fst

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

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

25 }

20 }

26

21

27 test1 :: forall a b c. Lens (Pair (Pair a b) c) a

22 test1 :: forall a b c. Lens (Pair (Pair a b) c) a

prelude/prelude.purs+43−13

@@ -614,13 +614,8 @@ module Arrays where

614 isEmpty _ = false

615

616 range :: Number -> Number -> [Number]

617− range lo hi = {

617+ range lo hi | lo > hi = []

618− var ns = [];

618+ range lo hi = lo : range (lo + 1) hi

619− for (n <- lo until hi) {

620− ns = push ns n;

621− }

622− return ns;

623− }

624

619

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

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

626 zipWith f (a:as) (b:bs) = f a b : zipWith f as bs

621 zipWith f (a:as) (b:bs) = f a b : zipWith f as bs

@@ -635,7 +630,6 @@ module Arrays where

635 all p (a:as) = p a && all p as

630 all p (a:as) = p a && all p as

636

631

637 instance (Prelude.Show a) => Prelude.Show [a] where

632 instance (Prelude.Show a) => Prelude.Show [a] where

638− show [] = "[]"

639 show xs = "[" ++ joinWith (map show xs) "," ++ "]"

633 show xs = "[" ++ joinWith (map show xs) "," ++ "]"

640

634

641 instance Prelude.Functor [] where

635 instance Prelude.Functor [] where

@@ -952,7 +946,7 @@ module Eff where

952 \ return {};\

946 \ return {};\

953 \ };\

947 \ };\

954 \ };\

948 \ };\

955− \}" :: forall e. Eff e Boolean -> Eff e {} -> Eff e {}

949+ \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e {}

956

950

957 foreign import forE "function forE(lo) {\

951 foreign import forE "function forE(lo) {\

958 \ return function(hi) {\

952 \ return function(hi) {\

@@ -1078,6 +1072,8 @@ module ST where

1078

1072

1079 foreign import data STRef :: * -> * -> *

1073 foreign import data STRef :: * -> * -> *

1080

1074

1075+ foreign import data STArray :: * -> * -> *

1076+

1081 foreign import newSTRef "function newSTRef(val) {\

1077 foreign import newSTRef "function newSTRef(val) {\

1082 \ return function () {\

1078 \ return function () {\

1083 \ return { value: val };\

1079 \ return { value: val };\

@@ -1093,20 +1089,54 @@ module ST where

1093 foreign import modifySTRef "function modifySTRef(ref) {\

1089 foreign import modifySTRef "function modifySTRef(ref) {\

1094 \ return function(f) {\

1090 \ return function(f) {\

1095 \ return function() {\

1091 \ return function() {\

1096− \ ref.value = f(ref.value);\

1092+ \ return ref.value = f(ref.value);\

1097 \ };\

1093 \ };\

1098 \ };\

1094 \ };\

1099− \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) {}

1095+ \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

1100

1096

1101 foreign import writeSTRef "function writeSTRef(ref) {\

1097 foreign import writeSTRef "function writeSTRef(ref) {\

1102 \ return function(a) {\

1098 \ return function(a) {\

1103 \ return function() {\

1099 \ return function() {\

1104− \ ref.value = a;\

1100+ \ return ref.value = a;\

1101+ \ };\

1102+ \ };\

1103+ \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

1104+

1105+ foreign import newSTArray "function newSTArray(len) {\

1106+ \ return function(a) {\

1107+ \ return function() {\

1108+ \ var arr = [];\

1109+ \ for (var i = 0; i < len; i++) {\

1110+ \ arr[i] = a;\

1111+ \ };\

1112+ \ return arr;\

1105 \ };\

1113 \ };\

1106 \ };\

1114 \ };\

1107− \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) {}

1115+ \}" :: forall a h r. Number -> a -> Eff (st :: ST h | r) (STArray h a)

1116+

1117+ foreign import peekSTArray "function peekSTArray(arr) {\

1118+ \ return function(i) {\

1119+ \ return function() {\

1120+ \ return arr[i];\

1121+ \ };\

1122+ \ };\

1123+ \}" :: forall a h r. STArray h a -> Eff (st :: ST h | r) a

1124+

1125+ foreign import pokeSTArray "function pokeSTArray(arr) {\

1126+ \ return function(i) {\

1127+ \ return function(a) {\

1128+ \ return function() {\

1129+ \ return arr[i] = a;\

1130+ \ };\

1131+ \ };\

1132+ \ };\

1133+ \}" :: forall a h r. STArray h a -> Number -> a -> Eff (st :: ST h | r) a

1108

1134

1109 foreign import runST "function runST(f) {\

1135 foreign import runST "function runST(f) {\

1110 \ return f;\

1136 \ return f;\

1111 \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

1137 \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

1112

1138

1139+ foreign import runSTArray "function runSTArray(f) {\

1140+ \ return f;\

1141+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) (STArray h a)) -> Eff r [a]

1142+

prelude/tests/Eff.purs+3−4

@@ -46,13 +46,12 @@ test7 _ = do

46

47test8 _ = (\_1 _2 -> {}) <$> print "Test" <*> print 8

48

49−test9 _ = do

49+test9 _ = runST (do

50 r <- newSTRef 1

51− untilE $ do

51+ whileE (return true) $ do

52 n <- readSTRef r

53 trace $ "Count " ++ show n

54− modifySTRef r $ (+) 1

54+ modifySTRef r $ (+) 1)

55− return false

56

55

57module Main where

56module Main where

58

57

psci/Main.hs+4−4

@@ -52,7 +52,7 @@ completion ms = completeWord Nothing " \t\n\r" findCompletions

52 | P.Module moduleName ds <- ms

53 , ident <- mapMaybe getDeclName ds

54 , qual <- [ P.Qualified Nothing ident

55− , P.Qualified (Just (P.ModuleName moduleName)) ident]

55+ , P.Qualified (Just moduleName) ident]

56 ]

57 let matches = filter (isPrefixOf str) names

58 return $ map simpleCompletion matches ++ files

@@ -63,16 +63,16 @@ completion ms = completeWord Nothing " \t\n\r" findCompletions

63createTemporaryModule :: [P.ProperName] -> P.Value -> P.Module

64createTemporaryModule imports value =

65 let

66− moduleName = P.ProperName "Main"

66+ moduleName = P.ModuleName [P.ProperName "Main"]

67 importDecl m = P.ImportDeclaration m Nothing

68− traceModule = P.ModuleName (P.ProperName "Trace")

68+ traceModule = P.ModuleName [P.ProperName "Trace"]

69 trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

70 mainDecl = P.ValueDeclaration (P.Ident "main") [] Nothing

71 (P.Do [ P.DoNotationBind (P.VarBinder (P.Ident "it")) value

72 , P.DoNotationValue (P.App trace (P.Var (P.Qualified Nothing (P.Ident "it"))) )

73 ])

74 in

75− P.Module moduleName $ map (importDecl . P.ModuleName) imports ++ [mainDecl]

75+ P.Module moduleName $ map (importDecl . P.ModuleName . return) imports ++ [mainDecl]

76

77handleDeclaration :: [P.Module] -> [P.ProperName] -> P.Value -> InputT IO ()

78handleDeclaration loadedModules imports value = do

purescript.cabal+1

@@ -36,6 +36,7 @@ library

36 Language.PureScript.Sugar.BindingGroups

37 Language.PureScript.Sugar.Operators

38 Language.PureScript.Sugar.TypeClasses

39+ Language.PureScript.Sugar.Let

39 Language.PureScript.CodeGen

40 Language.PureScript.CodeGen

40 Language.PureScript.CodeGen.Common

41 Language.PureScript.CodeGen.Common

41 Language.PureScript.CodeGen.Externs

42 Language.PureScript.CodeGen.Externs

src/Language/PureScript.hs+9−5

@@ -60,19 +60,23 @@ compile opts ms = do

60 sorted <- sortModules ms

61 desugared <- desugar sorted

62 (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do

63− modify (\s -> s { checkCurrentModule = Just (ModuleName moduleName) })

63+ modify (\s -> s { checkCurrentModule = Just moduleName })

64− Module moduleName <$> typeCheckAll mainModuleIdent (ModuleName moduleName) decls

64+ Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66− let entryPoints = optionsModules opts

66+ let entryPoints = (ModuleName . splitProperNames) `map` optionsModules opts

67 let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

68 let js = mapMaybe (flip (moduleToJs opts) env) elim

69 let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

70 js' <- case optionsMain opts of

71 Just mainModuleName -> do

72− when ((ModuleName (ProperName mainModuleName), Ident "main") `M.notMember` (names env)) $

72+ when ((ModuleName [ProperName mainModuleName], Ident "main") `M.notMember` (names env)) $

73 Left $ mainModuleName ++ ".main is undefined"

74 return $ js ++ [JSApp (JSAccessor "main" (JSAccessor mainModuleName (JSVar "_ps"))) []]

75 _ -> return js

76 return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)

77 where

78− mainModuleIdent = ModuleName . ProperName <$> (optionsMain opts)

78+ mainModuleIdent = ModuleName . splitProperNames <$> optionsMain opts

79+ splitProperNames s = case dropWhile (== '.') s of

80+ "" -> []

81+ s' -> ProperName w : splitProperNames s''

82+ where (w, s'') = break (== '.') s'

src/Language/PureScript/CodeGen/Common.hs+3

@@ -16,6 +16,7 @@

16module Language.PureScript.CodeGen.Common where

17

18import Data.Char

19+import Data.List (intercalate)

19import Language.PureScript.Names

20import Language.PureScript.Names

20

21

21-- |

22-- |

@@ -127,3 +128,5 @@ nameIsJsReserved name =

127 , "with"

128 , "with"

128 , "yield" ]

129 , "yield" ]

129

130

131+moduleNameToJs :: ModuleName -> String

132+moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

src/Language/PureScript/CodeGen/Externs.hs+3−3

@@ -29,9 +29,9 @@ import Data.List (intercalate)

29-- Generate foreign imports for all declarations in a module

30--

31moduleToPs :: Module -> Environment -> String

32−moduleToPs (Module pname@(ProperName moduleName) decls) env =

32+moduleToPs (Module mn decls) env =

33− "module " ++ moduleName ++ " where\n" ++

33+ "module " ++ (runModuleName mn) ++ " where\n" ++

34− (intercalate "\n" . map (" " ++) . concatMap (declToPs (ModuleName pname) env) $ decls)

34+ (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

35

36declToPs :: ModuleName -> Environment -> Declaration -> [String]

37declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

src/Language/PureScript/CodeGen/JS.hs+5−24

@@ -52,14 +52,14 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

52-- module.

53--

54moduleToJs :: Options -> Module -> Environment -> Maybe JS

55−moduleToJs opts (Module pname@(ProperName name) decls) env =

55+moduleToJs opts (Module name decls) env =

56 case jsDecls of

57 [] -> Nothing

58− _ -> Just $ JSAssignment (JSAccessor name (JSVar "_ps")) $

58+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

59 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

60− [(JSBinary Or (JSAccessor name (JSVar "_ps")) (JSObjectLiteral []))]

60+ [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]

61 where

62− jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (decls))

62+ jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))

63

64-- |

65-- Generate code in the simplified Javascript intermediate representation for a declaration

@@ -128,7 +128,6 @@ valueToJs _ m e (Constructor (Qualified Nothing name)) =

128 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS m id (Qualified (Just aliasModule) aliasIdent)

129 _ -> JSVar . runProperName $ name

130valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name

131−valueToJs opts m e (Block sts) = JSApp (JSFunction Nothing [] (JSBlock (map (statementToJs opts m e) sts))) []

132valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

131valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (valueToJs opts m e) values)

133valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

132valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)

134valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

133valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

@@ -212,7 +211,7 @@ varToJs m e qual@(Qualified _ ident) = go qual

212-- variable that may have a qualified name.

211-- variable that may have a qualified name.

213--

212--

214qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

213qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

215−qualifiedToJS m f (Qualified (Just m'@(ModuleName (ProperName mn))) a) | m /= m' = accessor (f a) (JSAccessor mn $ JSVar "_ps")

214+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")

216qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)

215qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)

217

216

218-- |

217-- |

@@ -326,24 +325,6 @@ isOnlyConstructor m e ctor =

326 typeConstructor (TypeApp ty _) = typeConstructor ty

325 typeConstructor (TypeApp ty _) = typeConstructor ty

327 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn

326 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn

328

327

329−-- |

330−-- Generate code in the simplified Javascript intermediate representation for a statement in a

331−-- PureScript block.

332−--

333−statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS

334−statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction (identToJs ident) (Just (valueToJs opts m e value))

335−statementToJs opts m e (Assignment target value) = JSAssignment (JSVar (identToJs target)) (valueToJs opts m e value)

336−statementToJs opts m e (While cond sts) = JSWhile (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) sts))

337−statementToJs opts m e (For ident start end sts) = JSFor (identToJs ident) (valueToJs opts m e start) (valueToJs opts m e end) (JSBlock (map (statementToJs opts m e) sts))

338−statementToJs opts m e (If ifst) = ifToJs ifst

339− where

340− ifToJs :: IfStatement -> JS

341− ifToJs (IfStatement cond thens elses) = JSIfElse (valueToJs opts m e cond) (JSBlock (map (statementToJs opts m e) thens)) (fmap elseToJs elses)

342− elseToJs :: ElseStatement -> JS

343− elseToJs (Else sts) = JSBlock (map (statementToJs opts m e) sts)

344− elseToJs (ElseIf elif) = ifToJs elif

345−statementToJs opts m e (Return value) = JSReturn (valueToJs opts m e value)

346−

347wrapExportsContainer :: Options -> [JS] -> JS

328wrapExportsContainer :: Options -> [JS] -> JS

348wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]

329wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]

349 where

330 where

src/Language/PureScript/CodeGen/Optimize.hs+101−15

@@ -38,7 +38,8 @@ module Language.PureScript.CodeGen.Optimize (

38) where

39

40import Data.Data

41−import Data.Maybe (fromMaybe)

41+import Data.List (nub)

42+import Data.Maybe (fromJust, isJust, fromMaybe)

42import Data.Generics

43import Data.Generics

43

44

44import Language.PureScript.Names

45import Language.PureScript.Names

@@ -95,6 +96,7 @@ isReassigned var1 = everything (||) (mkQ False check)

95 check :: JS -> Bool

96 check :: JS -> Bool

96 check (JSFunction _ args _) | var1 `elem` args = True

97 check (JSFunction _ args _) | var1 `elem` args = True

97 check (JSVariableIntroduction arg _) | var1 == arg = True

98 check (JSVariableIntroduction arg _) | var1 == arg = True

99+ check (JSAssignment (JSVar arg) _) | var1 == arg = True

98 check _ = False

100 check _ = False

99

101

100isRebound :: (Data d) => JS -> d -> Bool

102isRebound :: (Data d) => JS -> d -> Bool

@@ -254,52 +256,136 @@ tco' = everywhere (mkT convert)

254 isSelfCall _ _ = False

256 isSelfCall _ _ = False

255

257

256magicDo :: Options -> JS -> JS

258magicDo :: Options -> JS -> JS

257−magicDo opts | optionsMagicDo opts = magicDo'

259+magicDo opts | optionsMagicDo opts = inlineST . magicDo'

258 | otherwise = id

260 | otherwise = id

259

261

262+-- |

263+-- Inline type class dictionaries for >>= and return for the Eff monad

264+--

265+-- E.g.

266+--

267+-- Prelude[">>="](dict)(m1)(function(x) {

268+-- return ...;

269+-- })

270+--

271+-- becomes

272+--

273+-- function __do {

274+-- var x = m1();

275+-- ...

276+-- }

277+--

260magicDo' :: JS -> JS

278magicDo' :: JS -> JS

261magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

279magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

262 where

280 where

281+ -- The name of the function block which is added to denote a do block

263 fnName = "__do"

282 fnName = "__do"

264−

283+ -- Desugar monomorphic calls to >>= and return for the Eff monad

265 convert :: JS -> JS

284 convert :: JS -> JS

285+ -- Desugar return

266 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

286 convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

287+ -- Desugae >>

267 convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =

288 convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =

268 JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]

289 JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]

290+ -- Desugar >>=

269 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =

291 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =

270 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]

292 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]

293+ -- Desugar untilE

294+ convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =

295+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []

296+ -- Desugar whileE

297+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =

298+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []

271 convert other = other

299 convert other = other

272−

300+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad

273 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True

301 isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict effDict = True

274 isBind _ = False

302 isBind _ = False

275−

303+ -- Check if an expression represents a monomorphic call to return for the Eff monad

276 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True

304 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True

277 isReturn _ = False

305 isReturn _ = False

278−

306+ -- Check if an expression represents the polymorphic >>= function

279 isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True

307 isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True

280 isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True

308 isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True

281 isBindPoly _ = False

309 isBindPoly _ = False

282−

310+ -- Check if an expression represents the polymorphic return function

283 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True

311 isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True

284 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True

312 isRetPoly (JSIndexer (JSStringLiteral "return") (JSAccessor "Prelude" (JSVar "_ps"))) = True

285 isRetPoly _ = False

313 isRetPoly _ = False

286−

314+ -- Check if an expression represents a function in the Ef module

315+ isEffFunc name (JSAccessor name' (JSAccessor "Eff" (JSVar "_ps"))) | name == name' = True

316+ isEffFunc _ _ = False

317+ -- Module names

287− prelude = ModuleName (ProperName "Prelude")

318+ prelude = ModuleName [ProperName "Prelude"]

288− effModule = ModuleName (ProperName "Eff")

319+ effModule = ModuleName [ProperName "Eff"]

289−

320+ -- The name of the type class dictionary for the Monad Eff instance

290 Right (Ident effDictName) = mkDictionaryValueName

321 Right (Ident effDictName) = mkDictionaryValueName

291 effModule

322 effModule

292 (Qualified (Just prelude) (ProperName "Monad"))

323 (Qualified (Just prelude) (ProperName "Monad"))

293 (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))

324 (TypeConstructor (Qualified (Just effModule) (ProperName "Eff")))

294−

325+ -- Check if an expression represents the Monad Eff dictionary

295 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True

326 isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True

296 isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True

327 isEffDict (JSApp (JSAccessor prop (JSAccessor "Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True

297 isEffDict _ = False

328 isEffDict _ = False

298−

329+ -- Remove __do function applications which remain after desugaring

299 undo :: JS -> JS

330 undo :: JS -> JS

300 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

331 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

301 undo other = other

332 undo other = other

302

333

334+-- |

335+-- Inline functions in the ST module

336+--

337+inlineST :: JS -> JS

338+inlineST = everywhere (mkT convertBlock)

339+ where

340+ -- Look for runST blocks and inline the STRefs there.

341+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

342+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.

343+ convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =

344+ let refs = nub . findSTRefsIn $ arg

345+ usages = findAllSTUsagesIn arg

346+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

347+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs

348+ in everywhere (mkT $ convert allUsagesAreLocalVars) arg

349+ convertBlock other = other

350+ -- Convert a block in a safe way, preserving object wrappers of references,

351+ -- or in a more aggressive way, turning wrappers into local variables depending on the

352+ -- agg(ressive) parameter.

353+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =

354+ if agg then arg else JSObjectLiteral [("value", arg)]

355+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =

356+ if agg then ref else JSAccessor "value" ref

357+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =

358+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg

359+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =

360+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])

361+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =

362+ (JSIndexer i arr)

363+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =

364+ JSAssignment (JSIndexer i arr) val

365+ convert _ other = other

366+ -- Check if an expression represents a function in the ST module

367+ isSTFunc name (JSAccessor name' (JSAccessor "ST" (JSVar "_ps"))) | name == name' = True

368+ isSTFunc _ _ = False

369+ -- Find all ST Refs initialized in this block

370+ findSTRefsIn = everything (++) (mkQ [] isSTRef)

371+ where

372+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]

373+ isSTRef _ = []

374+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

375+ findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)

376+ where

377+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]

378+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]

379+ isSTUsage _ = []

380+ -- Find all uses of a variable

381+ appearingIn ref = everything (++) (mkQ [] isVar)

382+ where

383+ isVar e@(JSVar v) | v == ref = [e]

384+ isVar _ = []

385+ -- Convert a JS value to a String if it is a JSVar

386+ toVar (JSVar v) = Just v

387+ toVar _ = Nothing

388+

303collapseNestedBlocks :: JS -> JS

389collapseNestedBlocks :: JS -> JS

304collapseNestedBlocks = everywhere (mkT collapse)

390collapseNestedBlocks = everywhere (mkT collapse)

305 where

391 where

@@ -382,7 +468,7 @@ inlineCommonOperators = applyAll

382 isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

468 isOpDict className ty (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

383 where

469 where

384 Right (Ident dictName) = mkDictionaryValueName

470 Right (Ident dictName) = mkDictionaryValueName

385− (ModuleName (ProperName "Prim"))

471+ (ModuleName [ProperName "Prim"])

386− (Qualified (Just (ModuleName (ProperName "Prelude"))) (ProperName className))

472+ (Qualified (Just (ModuleName [ProperName "Prelude"])) (ProperName className))

387 ty

473 ty

388 isOpDict _ _ _ = False

474 isOpDict _ _ _ = False

src/Language/PureScript/DeadCodeElimination.hs+7−7

@@ -30,12 +30,12 @@ import Language.PureScript.TypeChecker.Monad

30-- |

31-- Eliminate all declarations which are not a transitive dependency of the entry point module

32--

33−eliminateDeadCode :: Environment -> [String] -> [Module] -> [Module]

33+eliminateDeadCode :: Environment -> [ModuleName] -> [Module] -> [Module]

34eliminateDeadCode env entryPoints ms =

35 let declarations = concatMap (declarationsByModule env) ms

36 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((ModuleName (ProperName mn), _), _) -> mn `elem` entryPoints) $ declarations

37+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

38− in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (ModuleName moduleName) graph vertexFor entryPointVertices) ds)

38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)

39

40type Key = (ModuleName, Either Ident ProperName)

41

@@ -43,10 +43,10 @@ declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43declarationsByModule env (Module moduleName ds) = concatMap go $ ds

44 where

45 go :: Declaration -> [(Key, [Key])]

46− go d@(ValueDeclaration name _ _ _) = [((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)]

46+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]

47− go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((ModuleName moduleName, Right name), [])) dctors

47+ go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

48− go (ExternDeclaration _ name _ _) = [((ModuleName moduleName, Left name), [])]

48+ go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

49− go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((ModuleName moduleName, Left name), dependencies env (ModuleName moduleName) d)) names

49+ go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names

50 go (DataBindingGroupDeclaration ds) = concatMap go ds

51 go _ = []

52

src/Language/PureScript/Declarations.hs+1−1

@@ -42,7 +42,7 @@ data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable

42-- |

43-- A module declaration, consisting of a module name and a list of declarations

44--

45−data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

45+data Module = Module ModuleName [Declaration] deriving (Show, D.Data, D.Typeable)

46

47-- |

48-- The type of a foreign import

src/Language/PureScript/ModuleDependencies.hs+9−9

@@ -40,21 +40,21 @@ sortModules ms = do

40-- |

41-- Calculate a list of used modules based on explicit imports and qualified names

42--

43−usedModules :: (Data d) => d -> [ProperName]

43+usedModules :: (Data d) => d -> [ModuleName]

44usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)

45 where

46− qualifiedIdents :: Qualified Ident -> [ProperName]

46+ qualifiedIdents :: Qualified Ident -> [ModuleName]

47− qualifiedIdents (Qualified (Just (ModuleName pn)) _) = [pn]

47+ qualifiedIdents (Qualified (Just mn) _) = [mn]

48 qualifiedIdents _ = []

49− qualifiedProperNames :: Qualified ProperName -> [ProperName]

49+ qualifiedProperNames :: Qualified ProperName -> [ModuleName]

50− qualifiedProperNames (Qualified (Just (ModuleName pn)) _) = [pn]

50+ qualifiedProperNames (Qualified (Just mn) _) = [mn]

51 qualifiedProperNames _ = []

52− imports :: Declaration -> [ProperName]

52+ imports :: Declaration -> [ModuleName]

53− imports (ImportDeclaration (ModuleName pn) _) = [pn]

53+ imports (ImportDeclaration mn _) = [mn]

54 imports _ = []

55

56−getModuleName :: Module -> ProperName

56+getModuleName :: Module -> ModuleName

57−getModuleName (Module pn _) = pn

57+getModuleName (Module mn _) = mn

58

59-- |

60-- Convert a strongly connected component of the module graph to a module

src/Language/PureScript/Names.hs+7−3

@@ -17,6 +17,7 @@

17

18module Language.PureScript.Names where

19

20+import Data.List

20import Data.Data

21import Data.Data

21import Data.Function (on)

22import Data.Function (on)

22

23

@@ -64,10 +65,13 @@ instance Show ProperName where

64-- |

65-- |

65-- Module names

66-- Module names

66--

67--

67−data ModuleName = ModuleName { runModuleName :: ProperName } deriving (Eq, Ord, Data, Typeable)

68+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)

69+

70+runModuleName :: ModuleName -> String

71+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)

68

72

69instance Show ModuleName where

73instance Show ModuleName where

70− show (ModuleName name) = show name

74+ show = runModuleName

71

75

72-- |

76-- |

73-- A qualified name, i.e. a name with an optional module name

77-- A qualified name, i.e. a name with an optional module name

@@ -76,7 +80,7 @@ data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typea

76

80

77instance (Show a) => Show (Qualified a) where

81instance (Show a) => Show (Qualified a) where

78 show (Qualified Nothing a) = show a

82 show (Qualified Nothing a) = show a

79− show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a

83+ show (Qualified (Just name) a) = show name ++ "." ++ show a

80

84

81-- |

85-- |

82-- Provide a default module name, if a name is unqualified

86-- Provide a default module name, if a name is unqualified

src/Language/PureScript/Parser/Common.hs+15−5

@@ -49,7 +49,8 @@ reservedPsNames = [ "data"

49 , "true"

50 , "false"

51 , "until"

52−

52+ , "let"

53+ , "in"

53 ]

54 ]

54

55

55-- |

56-- |

@@ -203,15 +204,24 @@ natural = PT.natural tokenParser

203properName :: P.Parsec String u ProperName

204properName :: P.Parsec String u ProperName

204properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")

205properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many P.alphaNum P.<?> "name")

205

206

207+-- |

208+-- Parse a module name

209+--

210+moduleName :: P.Parsec String ParseState ModuleName

211+moduleName = ModuleName <$> P.try (sepBy properName dot)

212+

206-- |

213-- |

207-- Parse a qualified name, i.e. M.name or just name

214-- Parse a qualified name, i.e. M.name or just name

208--

215--

209parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

216parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)

210−parseQualified parser = qual

217+parseQualified parser = part []

211 where

218 where

212− qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)

219+ part path = (do name <- P.try (properName <* delimiter)

220+ part (updatePath path name))

213− <|> (Qualified Nothing <$> P.try parser)

221+ <|> (Qualified (qual path) <$> P.try parser)

214− delimiter = indented *> dot

222+ delimiter = indented *> dot <* P.notFollowedBy dot

223+ updatePath path name = path ++ [name]

224+ qual path = if null path then Nothing else Just $ ModuleName path

215

225

216-- |

226-- |

217-- Parse an integer or floating point value

227-- Parse an integer or floating point value

src/Language/PureScript/Parser/Declarations.hs+2−2

@@ -89,7 +89,7 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration

89parseImportDeclaration = do

90 reserved "import"

91 indented

92− moduleName <- ModuleName <$> properName

92+ moduleName <- moduleName

93 idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

94 return $ ImportDeclaration moduleName idents

95

@@ -138,7 +138,7 @@ parseModule :: P.Parsec String ParseState Module

138parseModule = do

139 reserved "module"

140 indented

141− name <- properName

141+ name <- moduleName

142 _ <- lexeme $ P.string "where"

143 decls <- mark (P.many (same *> parseDeclaration))

144 return $ Module name decls

src/Language/PureScript/Parser/Values.hs+13−68

@@ -15,7 +15,6 @@

15

16module Language.PureScript.Parser.Values (

17 parseValue,

18− parseStatement,

19 parseGuard,

18 parseGuard,

20 parseBinder,

19 parseBinder,

21 parseBinderNoParens,

20 parseBinderNoParens,

@@ -83,16 +82,19 @@ parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parse

83 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

82 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

84 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

83 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

85

84

86−parseBlock :: P.Parsec String ParseState Value

85+parseLet :: P.Parsec String ParseState Value

87−parseBlock = Block <$> parseManyStatements

86+parseLet = do

88−

87+ C.reserved "let"

89−parseManyStatements :: P.Parsec String ParseState [Statement]

88+ C.indented

90−parseManyStatements = (do

89+ binder <- parseBinder

91− _ <- C.lexeme $ P.char '{'

90+ C.indented

91+ C.reservedOp "="

92+ C.indented

93+ value <- parseValue

92 C.indented

94 C.indented

93− sts <- C.mark (P.many (C.same *> C.mark parseStatement))

95+ C.reserved "in"

94− _ <- C.lexeme (P.char '}')

96+ result <- parseValue

95− return sts) P.<?> "block"

97+ return $ Let binder value result

96

98

97parseValueAtom :: P.Parsec String ParseState Value

99parseValueAtom :: P.Parsec String ParseState Value

98parseValueAtom = P.choice

100parseValueAtom = P.choice

@@ -104,10 +106,10 @@ parseValueAtom = P.choice

104 , parseAbs

106 , parseAbs

105 , P.try parseConstructor

107 , P.try parseConstructor

106 , P.try parseVar

108 , P.try parseVar

107− , parseBlock

108 , parseCase

109 , parseCase

109 , parseIfThenElse

110 , parseIfThenElse

110 , parseDo

111 , parseDo

112+ , parseLet

111 , Parens <$> C.parens parseValue ]

113 , Parens <$> C.parens parseValue ]

112

114

113parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

115parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

@@ -159,63 +161,6 @@ parseValue =

159 return (BinaryNoParens ident))) AssocRight ]

161 return (BinaryNoParens ident))) AssocRight ]

160 ]

162 ]

161

163

162−parseVariableIntroduction :: P.Parsec String ParseState Statement

163−parseVariableIntroduction = do

164− C.reserved "var"

165− name <- C.indented *> C.parseIdent

166− _ <- C.lexeme $ C.indented *> P.char '='

167− value <- parseValue

168− _ <- C.indented *> C.semi

169− return $ VariableIntroduction name value

170−

171−parseAssignment :: P.Parsec String ParseState Statement

172−parseAssignment = do

173− tgt <- P.try $ do

174− tgt <- C.parseIdent

175− _ <- C.lexeme $ C.indented *> P.char '='

176− return tgt

177− value <- parseValue

178− _ <- C.indented *> C.semi

179− return $ Assignment tgt value

180−

181−parseWhile :: P.Parsec String ParseState Statement

182−parseWhile = While <$> (C.reserved "while" *> C.indented *> C.parens parseValue)

183− <*> (C.indented *> parseManyStatements)

184−

185−parseFor :: P.Parsec String ParseState Statement

186−parseFor = For <$> (C.reserved "for" *> C.indented *> C.lexeme (P.char '(') *> C.indented *> C.parseIdent)

187− <*> (C.indented *> C.lexeme (P.string "<-") *> parseValue)

188− <*> (C.indented *> C.reserved "until" *> parseValue <* C.indented <* C.lexeme (P.char ')'))

189− <*> parseManyStatements

190−

191−parseIf :: P.Parsec String ParseState Statement

192−parseIf = If <$> parseIfStatement

193−

194−parseIfStatement :: P.Parsec String ParseState IfStatement

195−parseIfStatement =

196− IfStatement <$> (C.reserved "if" *> C.indented *> C.parens parseValue)

197− <*> parseManyStatements

198− <*> P.optionMaybe parseElseStatement

199−

200−parseElseStatement :: P.Parsec String ParseState ElseStatement

201−parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement

202− <|> Else <$> parseManyStatements)

203−

204−parseReturn :: P.Parsec String ParseState Statement

205−parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi)

206−

207−-- |

208−-- Parse a statement

209−--

210−parseStatement :: P.Parsec String ParseState Statement

211−parseStatement = P.choice

212− [ parseAssignment

213− , parseVariableIntroduction

214− , parseWhile

215− , parseFor

216− , parseIf

217− , parseReturn ] P.<?> "statement"

218−

219parseStringBinder :: P.Parsec String ParseState Binder

164parseStringBinder :: P.Parsec String ParseState Binder

220parseStringBinder = StringBinder <$> C.stringLiteral

165parseStringBinder = StringBinder <$> C.stringLiteral

221

166

src/Language/PureScript/Pretty/Values.hs−23

@@ -38,7 +38,6 @@ literals = mkPattern match

38 match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

39 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"

40 match (Constructor name) = Just $ show name

41− match (Block sts) = Just $ "do { " ++ intercalate " ; " (map prettyPrintStatement sts) ++ " }"

42 match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41 match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

43 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

42 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

44 match (Var ident) = Just $ show ident

43 match (Var ident) = Just $ show ident

@@ -148,25 +147,3 @@ prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder bi

148

147

149prettyPrintObjectProperty :: String -> Value -> String

148prettyPrintObjectProperty :: String -> Value -> String

150prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value

149prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value

151−

152−prettyPrintStatement :: Statement -> String

153−prettyPrintStatement (VariableIntroduction ident value) = "var " ++ show ident ++ " = " ++ prettyPrintValue value

154−prettyPrintStatement (Assignment target value) = show target ++ " = " ++ prettyPrintValue value

155−prettyPrintStatement (While cond sts) = "while " ++ prettyPrintValue cond ++ ": {" ++ intercalate ";" (map prettyPrintStatement sts) ++ " }"

156−prettyPrintStatement (For ident start end sts) = "for " ++ show ident

157− ++ " <- " ++ prettyPrintValue start

158− ++ " until " ++ prettyPrintValue end ++ ": {"

159− ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"

160−prettyPrintStatement (If ifst) = prettyPrintIfStatement ifst

161−prettyPrintStatement (Return value) = "return " ++ prettyPrintValue value

162−

163−prettyPrintIfStatement :: IfStatement -> String

164−prettyPrintIfStatement (IfStatement cond thens elst) =

165− "if "

166− ++ prettyPrintValue cond ++ ": {"

167− ++ intercalate "; " (map prettyPrintStatement thens) ++ " }"

168− ++ maybe "" prettyPrintElseStatement elst

169−

170−prettyPrintElseStatement :: ElseStatement -> String

171−prettyPrintElseStatement (Else sts) = "else: {" ++ intercalate "; " (map prettyPrintStatement sts) ++ " }"

172−prettyPrintElseStatement (ElseIf ifst) = "else " ++ prettyPrintIfStatement ifst

src/Language/PureScript/Scope.hs+1−5

@@ -30,16 +30,12 @@ import Language.PureScript.CodeGen.JS.AST

30-- Gather all used names appearing inside a value

31--

32usedNames :: (Data d) => d -> [Ident]

33−usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

33+usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJS) val

34 where

35 namesV :: Value -> [Ident]

36 namesV (Abs arg _) = [arg]

37 namesV (Var (Qualified Nothing name)) = [name]

38 namesV _ = []

39− namesS :: Statement -> [Ident]

40− namesS (VariableIntroduction name _) = [name]

41− namesS (For name _ _ _) = [name]

42− namesS _ = []

43 namesB :: Binder -> [Ident]

39 namesB :: Binder -> [Ident]

44 namesB (VarBinder name) = [name]

40 namesB (VarBinder name) = [name]

45 namesB _ = []

41 namesB _ = []

src/Language/PureScript/Sugar.hs+6−1

@@ -16,6 +16,7 @@

16module Language.PureScript.Sugar (desugar, module S) where

17

18import Control.Monad

19+import Control.Arrow ((>>>))

19

20

20import Language.PureScript.Declarations

21import Language.PureScript.Declarations

21

22

@@ -25,10 +26,13 @@ import Language.PureScript.Sugar.CaseDeclarations as S

25import Language.PureScript.Sugar.TypeDeclarations as S

26import Language.PureScript.Sugar.TypeDeclarations as S

26import Language.PureScript.Sugar.BindingGroups as S

27import Language.PureScript.Sugar.BindingGroups as S

27import Language.PureScript.Sugar.TypeClasses as S

28import Language.PureScript.Sugar.TypeClasses as S

29+import Language.PureScript.Sugar.Let as S

28

30

29-- |

31-- |

30-- The desugaring pipeline proceeds as follows:

32-- The desugaring pipeline proceeds as follows:

31--

33--

34+-- * Desugar let bindings

35+--

32-- * Introduce type synonyms for type class dictionaries

36-- * Introduce type synonyms for type class dictionaries

33--

37--

34-- * Rebracket user-defined binary operators

38-- * Rebracket user-defined binary operators

@@ -45,6 +49,7 @@ desugar :: [Module] -> Either String [Module]

45desugar = desugarTypeClasses

49desugar = desugarTypeClasses

46 >=> rebracket

50 >=> rebracket

47 >=> desugarDo

51 >=> desugarDo

52+ >=> desugarLetBindings

48− >=> desugarCasesModule

53+ >>> desugarCasesModule

49 >=> desugarTypeDeclarationsModule

54 >=> desugarTypeDeclarationsModule

50 >=> createBindingGroupsModule

55 >=> createBindingGroupsModule

src/Language/PureScript/Sugar/BindingGroups.hs+1−1

@@ -36,7 +36,7 @@ import Language.PureScript.Types

36-- Replace all sets of mutually-recursive declarations in a module with binding groups

37--

38createBindingGroupsModule :: [Module] -> Either String [Module]

39−createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups (ModuleName name) ds

39+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups name ds

40

41-- |

42-- Collapse all binding groups in a module to individual declarations

src/Language/PureScript/Sugar/DoNotation.hs+1−1

@@ -33,7 +33,7 @@ desugarDo :: (Data d) => d -> Either String d

33desugarDo = everywhereM (mkM replace)

34 where

35 prelude :: ModuleName

36− prelude = ModuleName (ProperName "Prelude")

36+ prelude = ModuleName [ProperName "Prelude"]

37 ret :: Value

38 ret = Var (Qualified (Just prelude) (Ident "ret"))

39 bind :: Value

src/Language/PureScript/Sugar/Let.hsnew file+32

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

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Let

4+-- Copyright : (c) Phil Freeman 2014

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the desugaring pass which turns let bindings into function applications.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Sugar.Let (

17+ desugarLetBindings

18+) where

19+

20+import Data.Generics (mkT, everywhere)

21+

22+import Language.PureScript.Values

23+import Language.PureScript.Declarations

24+

25+-- |

26+-- Turn let bindings into function applications

27+--

28+desugarLetBindings :: [Module] -> [Module]

29+desugarLetBindings = everywhere (mkT go)

30+ where

31+ go (Let binder value result) = Case [value] [([binder], Nothing, result)]

32+ go other = other

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -46,9 +46,9 @@ rebracket = go M.empty []

46 where

47 go _ rb [] = return . reverse $ rb

48 go m rb (Module name ds : ms) = do

49− m' <- M.union m <$> collectFixities m (ModuleName name) ds

49+ m' <- M.union m <$> collectFixities m name ds

50 let opTable = customOperatorTable m'

51− ds' <- G.everywhereM' (G.mkM (matchOperators (ModuleName name) opTable)) ds

51+ ds' <- G.everywhereM' (G.mkM (matchOperators name opTable)) ds

52 go m' (Module name (G.everywhere (G.mkT removeParens) ds') : rb) ms

53

54removeParens :: Value -> Value

src/Language/PureScript/Sugar/TypeClasses.hs+3−3

@@ -36,7 +36,7 @@ import Control.Arrow ((***))

36import Data.Maybe (fromMaybe)

37import Data.List (nub)

38import Data.Generics (mkQ, everything)

39−import Language.PureScript.CodeGen.Common (identToJs)

39+import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)

40

41type MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)])

42

@@ -50,7 +50,7 @@ desugarTypeClasses :: [Module] -> Either String [Module]

50desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

51

52desugarModule :: Module -> Desugar Module

53−desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl (ModuleName name)) decls

53+desugarModule (Module name decls) = Module name <$> concat <$> mapM (desugarDecl name) decls

54

55-- |

56-- Desugar type class and type class instance declarations

@@ -159,7 +159,7 @@ typeInstanceDictionaryEntryDeclaration _ _ _ _ _ = error "Invalid declaration in

159

160qualifiedToString :: ModuleName -> Qualified ProperName -> String

161qualifiedToString mn (Qualified Nothing pn) = qualifiedToString mn (Qualified (Just mn) pn)

162−qualifiedToString _ (Qualified (Just (ModuleName mn)) pn) = runProperName mn ++ "_" ++ runProperName pn

162+qualifiedToString _ (Qualified (Just mn) pn) = moduleNameToJs mn ++ "_" ++ runProperName pn

163

164-- |

165-- Generate a name for a type class dictionary, based on the module name, class name and type name

src/Language/PureScript/TypeChecker/Monad.hs+5−5

@@ -118,11 +118,11 @@ data Environment = Environment {

118-- The basic types existing in the external javascript environment

119--

120jsTypes ::M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

121−jsTypes = M.fromList [ ((ModuleName $ ProperName "Prim", ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

121+jsTypes = M.fromList [ ((ModuleName [ProperName "Prim"], ProperName "Function"), (FunKind Star $ FunKind Star Star, ExternData))

122− , ((ModuleName $ ProperName "Prim", ProperName "Array"), (FunKind Star Star, ExternData))

122+ , ((ModuleName [ProperName "Prim"], ProperName "Array"), (FunKind Star Star, ExternData))

123− , ((ModuleName $ ProperName "Prim", ProperName "String"), (Star, ExternData))

123+ , ((ModuleName [ProperName "Prim"], ProperName "String"), (Star, ExternData))

124− , ((ModuleName $ ProperName "Prim", ProperName "Number"), (Star, ExternData))

124+ , ((ModuleName [ProperName "Prim"], ProperName "Number"), (Star, ExternData))

125− , ((ModuleName $ ProperName "Prim", ProperName "Boolean"), (Star, ExternData)) ]

125+ , ((ModuleName [ProperName "Prim"], ProperName "Boolean"), (Star, ExternData)) ]

126

127-- |

128-- The initial environment with no values and only the default javascript types defined

src/Language/PureScript/TypeChecker/Types.hs+1−81

@@ -208,7 +208,7 @@ typesOf mainModuleName moduleName vals = do

208 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

209 when (Just moduleName == mainModuleName && fst e == Ident "main") $ do

210 [eff, a] <- replicateM 2 fresh

211− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName (ProperName "Eff"))) (ProperName "Eff"))) eff) a

211+ ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Eff"])) (ProperName "Eff"))) eff) a

212 -- Make sure unification variables do not escape

213 escapeCheck val ty

214 return triple

@@ -543,11 +543,6 @@ infer' (Var var) = do

543 dicts <- getTypeClassDictionaries

544 return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) (qualifyAllUnqualifiedNames moduleName env constraints))) ty'

545 _ -> return $ TypedValue True (Var var) ty

546−infer' (Block ss) = do

547− ret <- fresh

548− (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

549− guardWith "Block is missing a return statement" allCodePathsReturn

550− return $ TypedValue True (Block ss') ret

551infer' v@(Constructor c) = do

546infer' v@(Constructor c) = do

552 env <- getEnv

547 env <- getEnv

553 Just moduleName <- checkCurrentModule <$> get

548 Just moduleName <- checkCurrentModule <$> get

@@ -672,77 +667,6 @@ assignVariable name = do

672 Just _ -> UnifyT . lift . throwError $ "Variable with name " ++ show name ++ " already exists."

667 Just _ -> UnifyT . lift . throwError $ "Variable with name " ++ show name ++ " already exists."

673 _ -> return ()

668 _ -> return ()

674

669

675−-- |

676−-- Check the type of the return values of a statement, returning whether or not the statement returns on

677−-- all code paths

678−--

679−checkStatement :: M.Map Ident Type -> Type -> Statement -> UnifyT Type Check (Bool, M.Map Ident Type, Statement)

680−checkStatement mass _ (VariableIntroduction name val) = do

681− assignVariable name

682− val'@(TypedValue _ _ t) <- infer val

683− return (False, M.insert name t mass, VariableIntroduction name val')

684−checkStatement mass _ (Assignment ident val) = do

685− val'@(TypedValue _ _ t) <- infer val

686− case M.lookup ident mass of

687− Nothing -> throwError $ "No local variable with name " ++ show ident

688− Just ty -> do t =?= ty

689− return (False, mass, Assignment ident val')

690−checkStatement mass ret (While val inner) = do

691− val' <- check val tyBoolean

692− (allCodePathsReturn, _, inner') <- checkBlock mass ret inner

693− return (allCodePathsReturn, mass, While val' inner')

694−checkStatement mass ret (If ifst) = do

695− (allCodePathsReturn, ifst') <- checkIfStatement mass ret ifst

696− return (allCodePathsReturn, mass, If ifst')

697−checkStatement mass ret (For ident start end inner) = do

698− Just moduleName <- checkCurrentModule <$> get

699− assignVariable ident

700− start' <- check start tyNumber

701− end' <- check end tyNumber

702− (allCodePathsReturn, _, inner') <- bindLocalVariables moduleName [(ident, tyNumber)] $ checkBlock mass ret inner

703− return (allCodePathsReturn, mass, For ident start' end' inner')

704−checkStatement mass ret (Return val) = do

705− val' <- check val ret

706− return (True, mass, Return (TypedValue True val' ret))

707−

708−-- |

709−-- Check the type of an if-then-else statement

710−--

711−checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> UnifyT Type Check (Bool, IfStatement)

712−checkIfStatement mass ret (IfStatement val thens Nothing) = do

713− val' <- check val tyBoolean

714− (_, _, thens') <- checkBlock mass ret thens

715− return (False, IfStatement val' thens' Nothing)

716−checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

717− val' <- check val tyBoolean

718− (allCodePathsReturn1, _, thens') <- checkBlock mass ret thens

719− (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses

720− return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))

721−

722−-- |

723−-- Check the type of an else statement

724−--

725−checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> UnifyT Type Check (Bool, ElseStatement)

726−checkElseStatement mass ret (Else elses) = do

727− (allCodePathsReturn, _, elses') <- checkBlock mass ret elses

728− return (allCodePathsReturn, Else elses')

729−checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst

730−

731−-- |

732−-- Check the type of the return value of a block of statements

733−--

734−checkBlock :: M.Map Ident Type -> Type -> [Statement] -> UnifyT Type Check (Bool, M.Map Ident Type, [Statement])

735−checkBlock mass _ [] = return (False, mass, [])

736−checkBlock mass ret (s:ss) = do

737− Just moduleName <- checkCurrentModule <$> get

738− (b1, mass1, s') <- checkStatement mass ret s

739− bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of

740− (True, []) -> return (True, mass1, [s'])

741− (True, _) -> throwError "Unreachable code"

742− (False, ss') -> do

743− (b, m, ss'') <- checkBlock mass1 ret ss'

744− return (b, m, s':ss'')

745−

746-- |

670-- |

747-- Generate a new skolem constant

671-- Generate a new skolem constant

748--

672--

@@ -879,10 +803,6 @@ check' (Accessor prop val) ty = do

879 rest <- fresh

803 rest <- fresh

880 val' <- check val (Object (RCons prop ty rest))

804 val' <- check val (Object (RCons prop ty rest))

881 return $ TypedValue True (Accessor prop val') ty

805 return $ TypedValue True (Accessor prop val') ty

882−check' (Block ss) ret = do

883− (allCodePathsReturn, _, ss') <- checkBlock M.empty ret ss

884− guardWith "Block is missing a return statement" allCodePathsReturn

885− return $ TypedValue True (Block ss') ret

886check' (Constructor c) ty = do

806check' (Constructor c) ty = do

887 env <- getEnv

807 env <- getEnv

888 Just moduleName <- checkCurrentModule <$> get

808 Just moduleName <- checkCurrentModule <$> get

src/Language/PureScript/Types.hs+5−5

@@ -92,31 +92,31 @@ data Type

92-- Type constructor for functions

93--

94tyFunction :: Type

95−tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Function")

95+tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")

96

97-- |

98-- Type constructor for strings

99--

100tyString :: Type

101−tyString = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "String")

101+tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")

102

103-- |

104-- Type constructor for numbers

105--

106tyNumber :: Type

107−tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Number")

107+tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")

108

109-- |

110-- Type constructor for booleans

111--

112tyBoolean :: Type

113−tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Boolean")

113+tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")

114

115-- |

116-- Type constructor for arrays

117--

118tyArray :: Type

119−tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName $ ProperName "Prim") (ProperName "Array")

119+tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

120

121-- |

122-- Smart constructor for function types

src/Language/PureScript/Values.hs+4−55

@@ -86,10 +86,6 @@ data Value

86 --

87 | IfThenElse Value Value Value

88 -- |

89− -- A \"Block\" i.e. a collection of statements which evaluate to a value

90− --

91− | Block [Statement]

92− -- |

93 -- A data constructor

89 -- A data constructor

94 --

90 --

95 | Constructor (Qualified ProperName)

91 | Constructor (Qualified ProperName)

@@ -103,6 +99,10 @@ data Value

103 --

99 --

104 | TypedValue Bool Value Type

100 | TypedValue Bool Value Type

105 -- |

101 -- |

102+ -- A let binding

103+ --

104+ | Let Binder Value Value

105+ -- |

106 -- A do-notation block

107 --

108 | Do [DoNotationElement]

@@ -171,57 +171,6 @@ data DoNotationElement

171 --

172 | DoNotationLet Binder Value deriving (Show, Data, Typeable)

173

174−-- |

175−-- Data type for statements which can appear inside a @Block@ expression

176−--

177−data Statement

178− -- |

179− -- A variable introduction and initial assignment

180− --

181− = VariableIntroduction Ident Value

182− -- |

183− -- A variable reassignment

184− --

185− | Assignment Ident Value

186− -- |

187− -- A while loop

188− --

189− | While Value [Statement]

190− -- |

191− -- A for loop

192− --

193− | For Ident Value Value [Statement]

194− -- |

195− -- An if-then-else statement

196− --

197− | If IfStatement

198− -- |

199− -- A return statement

200− --

201− | Return Value deriving (Show, Data, Typeable)

202−

203−-- |

204−-- Data type for if-statements

205−--

206−data IfStatement

207− -- |

208− -- An if statement. Arguments are (in order): boolean condition, true branch, optional else branch.

209− --

210− = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)

211−

212−-- |

213−-- Data type for the else branch in an if-statement

214−--

215−data ElseStatement

216− -- |

217− -- An else branch

218− --

219− = Else [Statement]

220− -- |

221− -- An else-if branch

222− --

223− | ElseIf IfStatement deriving (Show, Data, Typeable)

224−

225-- |

174-- |

226-- Data type for binders

175-- Data type for binders

227--

176--