7de366c · rowtype-yoga/purescript-native

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

Merge branch 'master' of github.com:purescript/purescript into psci-fixes

commit7de366cfc3ba1b89a3f28fdf7e76ccd7b355d642 authorjoneshf <jones3.hardy@gmail.com> dateMon 17 Feb 2014, 22:08 (13 years ago) parent3fcc176 4f0ea32

43 files changed+388−566

compare with golang

unifiedsplit

RELEASE-0.5.md+4−2

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

33## Breaking Changes

5−-

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

77### New Features

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

1111### Enhancements

1212

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

1416

1517### Bug Fixes

1618

17−-

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

1820

1921### Libraries

2022

docgen/Main.hs+2−2

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

5959 mapM_ renderModule ms

6060

6161renderModule :: P.Module -> Docs

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

63− headerLevel 2 $ "Module " ++ moduleName

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

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

6464 spacer

6565 headerLevel 3 "Types"

6666 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:

1515 types

1616 kinds

1717 syntax

18− blocks

1918 typeclasses

2019 patterns

2120 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

88- Support for basic Javascript types

99- Extensible records

1010- Extensible effects

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

11+- Optimizer rules for generation of efficient Javascript

1212- Pattern matching

1313- Simple FFI

1414- Modules

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

6464

6565I 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.

6666

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.

6868

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

7070

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

3+import Prelude

4+import Eff

5+import ST

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

3+ class Foo a where

4+ foo :: a -> a

6+ data Text = Text String

8+ x = Text "Done"

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

55 yield = 0

66 member = 1

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−

308 public = \return -> return

319

10+ this catch = catch

11+

3212module Main where

3313

3414 import Prelude

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

3717

3818 main = Trace.print [ yield

3919 , member

40− , this

41− , catch

42− , instanceof

43− , public 1 ]

20+ , this 1

21+ , public 1 ]

examples/passing/Let.pursnew file+18

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

1+module Main where

3+import Prelude

4+import Eff

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

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

3+import Prelude

4+import Eff

5+import ST

6+import Arrays

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

1414

1515module Main where

1616

17−main = Trace.trace "Done"

17+import Prelude

18+import TailCall

19+

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

examples/passing/TypeDecl.purs+4−10

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

11module TypeDecl where

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

4− id = \x -> x

3+ import Prelude

65 k :: String -> Number -> String

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

6+ k x y = x

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

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

11− var result = a;

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

13− result = f result;

14− }

15− return result;

16− }

9+ iterate 0 f a = a

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

1711

1812module Main where

1913

examples/passing/TypeSynonyms.purs+2−7

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

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

99 composeLenses = \l1 -> \l2 ->

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

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

12− {

13− var b = l1.get a;

14− var b1 = l2.set b c;

15− return l1.set a b1;

16− }

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

1712 }

1813

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

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

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

2217 fst =

2318 { get: \p -> p.fst

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

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

2520 }

2621

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

prelude/prelude.purs+43−13

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

614614 isEmpty _ = false

615615

616616 range :: Number -> Number -> [Number]

617− range lo hi = {

618− var ns = [];

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

620− ns = push ns n;

621− }

622− return ns;

623− }

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

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

624619

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

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

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

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

636631

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

638− show [] = "[]"

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

640634

641635 instance Prelude.Functor [] where

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

952946 \ return {};\

953947 \ };\

954948 \ };\

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

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

956950

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

958952 \ return function(hi) {\

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

10781072

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

10801074

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

1076+

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

10821078 \ return function () {\

10831079 \ return { value: val };\

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

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

10941090 \ return function(f) {\

10951091 \ return function() {\

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

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

10971093 \ };\

10981094 \ };\

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

11001096

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

11021098 \ return function(a) {\

11031099 \ 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;\

11051113 \ };\

11061114 \ };\

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

11081134

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

11101136 \ return f;\

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

11121138

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

4646

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

4848

49−test9 _ = do

49+test9 _ = runST (do

5050 r <- newSTRef 1

51− untilE $ do

51+ whileE (return true) $ do

5252 n <- readSTRef r

5353 trace $ "Count " ++ show n

54− modifySTRef r $ (+) 1

55− return false

54+ modifySTRef r $ (+) 1)

5655

5756module Main where

5857

psci/Main.hs+4−4

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

5252 | P.Module moduleName ds <- ms

5353 , ident <- mapMaybe getDeclName ds

5454 , qual <- [ P.Qualified Nothing ident

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

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

5656 ]

5757 let matches = filter (isPrefixOf str) names

5858 return $ map simpleCompletion matches ++ files

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

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

6464createTemporaryModule imports value =

6565 let

66− moduleName = P.ProperName "Main"

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

6767 importDecl m = P.ImportDeclaration m Nothing

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

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

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

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

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

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

7373 ])

7474 in

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

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

7676

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

7878handleDeclaration loadedModules imports value = do

purescript.cabal+1

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

3636 Language.PureScript.Sugar.BindingGroups

3737 Language.PureScript.Sugar.Operators

3838 Language.PureScript.Sugar.TypeClasses

39+ Language.PureScript.Sugar.Let

3940 Language.PureScript.CodeGen

4041 Language.PureScript.CodeGen.Common

4142 Language.PureScript.CodeGen.Externs

src/Language/PureScript.hs+9−5

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

6060 sorted <- sortModules ms

6161 desugared <- desugar sorted

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

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

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

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

64+ Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls

6565 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

66− let entryPoints = optionsModules opts

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

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

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

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

7070 js' <- case optionsMain opts of

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

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

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

7575 _ -> return js

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

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

1616module Language.PureScript.CodeGen.Common where

1717

1818import Data.Char

19+import Data.List (intercalate)

1920import Language.PureScript.Names

2021

2122-- |

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

127128 , "with"

128129 , "yield" ]

129130

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)

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

3030--

3131moduleToPs :: Module -> Environment -> String

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

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

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

32+moduleToPs (Module mn decls) env =

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

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

3535

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

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

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

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

5252-- module.

5353--

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

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

55+moduleToJs opts (Module name decls) env =

5656 case jsDecls of

5757 [] -> Nothing

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

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

5959 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 []))]

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

6363

6464-- |

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

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

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

129129 _ -> JSVar . runProperName $ name

130130valueToJs _ 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))) []

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

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

134133valueToJs 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

212211-- variable that may have a qualified name.

213212--

214213qualifiedToJS :: 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")

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

217216

218217-- |

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

326325 typeConstructor (TypeApp ty _) = typeConstructor ty

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

328327

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−

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

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

349330 where

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

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

3838) where

3939

4040import Data.Data

41−import Data.Maybe (fromMaybe)

41+import Data.List (nub)

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

4243import Data.Generics

4344

4445import Language.PureScript.Names

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

9596 check :: JS -> Bool

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

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

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

98100 check _ = False

99101

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

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

254256 isSelfCall _ _ = False

255257

256258magicDo :: Options -> JS -> JS

257−magicDo opts | optionsMagicDo opts = magicDo'

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

258260 | otherwise = id

259261

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

260278magicDo' :: JS -> JS

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

262280 where

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

263282 fnName = "__do"

264−

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

265284 convert :: JS -> JS

285+ -- Desugar return

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

287+ -- Desugae >>

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

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

290+ -- Desugar >>=

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

270292 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 []) ])) []

271299 convert other = other

272−

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

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

274302 isBind _ = False

275−

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

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

277305 isReturn _ = False

278−

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

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

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

281309 isBindPoly _ = False

282−

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

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

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

285313 isRetPoly _ = False

286−

287− prelude = ModuleName (ProperName "Prelude")

288− effModule = ModuleName (ProperName "Eff")

289−

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

318+ prelude = ModuleName [ProperName "Prelude"]

319+ effModule = ModuleName [ProperName "Eff"]

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

290321 Right (Ident effDictName) = mkDictionaryValueName

291322 effModule

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

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

294−

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

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

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

297328 isEffDict _ = False

298−

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

299330 undo :: JS -> JS

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

301332 undo other = other

302333

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+

303389collapseNestedBlocks :: JS -> JS

304390collapseNestedBlocks = everywhere (mkT collapse)

305391 where

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

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

383469 where

384470 Right (Ident dictName) = mkDictionaryValueName

385− (ModuleName (ProperName "Prim"))

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

471+ (ModuleName [ProperName "Prim"])

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

387473 ty

388474 isOpDict _ _ _ = False

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

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

3030-- |

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

3232--

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

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

3434eliminateDeadCode env entryPoints ms =

3535 let declarations = concatMap (declarationsByModule env) ms

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

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

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

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

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

3939

4040type Key = (ModuleName, Either Ident ProperName)

4141

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

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

4444 where

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

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

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

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

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

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

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

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

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

5050 go (DataBindingGroupDeclaration ds) = concatMap go ds

5151 go _ = []

5252

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

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

4242-- |

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

4444--

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

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

4646

4747-- |

4848-- The type of a foreign import

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

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

4040-- |

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

4242--

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

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

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

4545 where

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

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

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

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

4848 qualifiedIdents _ = []

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

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

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

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

5151 qualifiedProperNames _ = []

52− imports :: Declaration -> [ProperName]

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

52+ imports :: Declaration -> [ModuleName]

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

5454 imports _ = []

5555

56−getModuleName :: Module -> ProperName

57−getModuleName (Module pn _) = pn

56+getModuleName :: Module -> ModuleName

57+getModuleName (Module mn _) = mn

5858

5959-- |

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

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

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

1717

1818module Language.PureScript.Names where

1919

20+import Data.List

2021import Data.Data

2122import Data.Function (on)

2223

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

6465-- |

6566-- Module names

6667--

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)

6872

6973instance Show ModuleName where

70− show (ModuleName name) = show name

74+ show = runModuleName

7175

7276-- |

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

7680

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

7882 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

8084

8185-- |

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

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

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

4949 , "true"

5050 , "false"

5151 , "until"

52−

52+ , "let"

53+ , "in"

5354 ]

5455

5556-- |

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

203204properName :: P.Parsec String u ProperName

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

205206

207+-- |

208+-- Parse a module name

209+--

210+moduleName :: P.Parsec String ParseState ModuleName

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

212+

206213-- |

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

208215--

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

210−parseQualified parser = qual

217+parseQualified parser = part []

211218 where

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

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

214− delimiter = indented *> dot

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

220+ part (updatePath path name))

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

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

215225

216226-- |

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

8989parseImportDeclaration = do

9090 reserved "import"

9191 indented

92− moduleName <- ModuleName <$> properName

92+ moduleName <- moduleName

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

9494 return $ ImportDeclaration moduleName idents

9595

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

138138parseModule = do

139139 reserved "module"

140140 indented

141− name <- properName

141+ name <- moduleName

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

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

144144 return $ Module name decls

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

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

1515

1616module Language.PureScript.Parser.Values (

1717 parseValue,

18− parseStatement,

1918 parseGuard,

2019 parseBinder,

2120 parseBinderNoParens,

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

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

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

8584

86−parseBlock :: P.Parsec String ParseState Value

87−parseBlock = Block <$> parseManyStatements

88−

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

90−parseManyStatements = (do

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

85+parseLet :: P.Parsec String ParseState Value

86+parseLet = do

87+ C.reserved "let"

88+ C.indented

89+ binder <- parseBinder

90+ C.indented

91+ C.reservedOp "="

92+ C.indented

93+ value <- parseValue

9294 C.indented

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

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

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

95+ C.reserved "in"

96+ result <- parseValue

97+ return $ Let binder value result

9698

9799parseValueAtom :: P.Parsec String ParseState Value

98100parseValueAtom = P.choice

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

104106 , parseAbs

105107 , P.try parseConstructor

106108 , P.try parseVar

107− , parseBlock

108109 , parseCase

109110 , parseIfThenElse

110111 , parseDo

112+ , parseLet

111113 , Parens <$> C.parens parseValue ]

112114

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

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

159161 return (BinaryNoParens ident))) AssocRight ]

160162 ]

161163

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−

219164parseStringBinder :: P.Parsec String ParseState Binder

220165parseStringBinder = StringBinder <$> C.stringLiteral

221166

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

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

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

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

4040 match (Constructor name) = Just $ show name

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

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

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

4443 match (Var ident) = Just $ show ident

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

148147

149148prettyPrintObjectProperty :: String -> Value -> String

150149prettyPrintObjectProperty 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

3030-- Gather all used names appearing inside a value

3131--

3232usedNames :: (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

3434 where

3535 namesV :: Value -> [Ident]

3636 namesV (Abs arg _) = [arg]

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

3838 namesV _ = []

39− namesS :: Statement -> [Ident]

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

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

42− namesS _ = []

4339 namesB :: Binder -> [Ident]

4440 namesB (VarBinder name) = [name]

4541 namesB _ = []

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

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

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

1717

1818import Control.Monad

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

1920

2021import Language.PureScript.Declarations

2122

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

2526import Language.PureScript.Sugar.TypeDeclarations as S

2627import Language.PureScript.Sugar.BindingGroups as S

2728import Language.PureScript.Sugar.TypeClasses as S

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

2830

2931-- |

3032-- The desugaring pipeline proceeds as follows:

3133--

34+-- * Desugar let bindings

35+--

3236-- * Introduce type synonyms for type class dictionaries

3337--

3438-- * Rebracket user-defined binary operators

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

4549desugar = desugarTypeClasses

4650 >=> rebracket

4751 >=> desugarDo

48− >=> desugarCasesModule

52+ >=> desugarLetBindings

53+ >>> desugarCasesModule

4954 >=> desugarTypeDeclarationsModule

5055 >=> createBindingGroupsModule

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

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

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

3737--

3838createBindingGroupsModule :: [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

4040

4141-- |

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

3333desugarDo = everywhereM (mkM replace)

3434 where

3535 prelude :: ModuleName

36− prelude = ModuleName (ProperName "Prelude")

36+ prelude = ModuleName [ProperName "Prelude"]

3737 ret :: Value

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

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

4646 where

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

4848 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

5050 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

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

5353

5454removeParens :: Value -> Value

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

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

3636import Data.Maybe (fromMaybe)

3737import Data.List (nub)

3838import Data.Generics (mkQ, everything)

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

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

4040

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

4242

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

5050desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule

5151

5252desugarModule :: 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

5454

5555-- |

5656-- Desugar type class and type class instance declarations

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

159159

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

161161qualifiedToString 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

163163

164164-- |

165165-- 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 {

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

119119--

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

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

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

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

125− , ((ModuleName $ ProperName "Prim", ProperName "Boolean"), (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))

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

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

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

126126

127127-- |

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

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

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

210210 [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

212212 -- Make sure unification variables do not escape

213213 escapeCheck val ty

214214 return triple

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

543543 dicts <- getTypeClassDictionaries

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

545545 _ -> 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

551546infer' v@(Constructor c) = do

552547 env <- getEnv

553548 Just moduleName <- checkCurrentModule <$> get

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

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

673668 _ -> return ()

674669

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−

746670-- |

747671-- Generate a new skolem constant

748672--

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

879803 rest <- fresh

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

881805 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

886806check' (Constructor c) ty = do

887807 env <- getEnv

888808 Just moduleName <- checkCurrentModule <$> get

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

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

9292-- Type constructor for functions

9393--

9494tyFunction :: Type

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

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

9696

9797-- |

9898-- Type constructor for strings

9999--

100100tyString :: Type

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

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

102102

103103-- |

104104-- Type constructor for numbers

105105--

106106tyNumber :: Type

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

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

108108

109109-- |

110110-- Type constructor for booleans

111111--

112112tyBoolean :: Type

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

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

114114

115115-- |

116116-- Type constructor for arrays

117117--

118118tyArray :: Type

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

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

120120

121121-- |

122122-- Smart constructor for function types

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

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

8686 --

8787 | IfThenElse Value Value Value

8888 -- |

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

90− --

91− | Block [Statement]

92− -- |

9389 -- A data constructor

9490 --

9591 | Constructor (Qualified ProperName)

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

10399 --

104100 | TypedValue Bool Value Type

105101 -- |

102+ -- A let binding

103+ --

104+ | Let Binder Value Value

105+ -- |

106106 -- A do-notation block

107107 --

108108 | Do [DoNotationElement]

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

171171 --

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

173173

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−

225174-- |

226175-- Data type for binders

227176--