5bae73f · rowtype-yoga/purescript-native

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

on golang help sign in

Constants module #236

5bae73fPhil Freeman13 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -26,6 +26,7 @@ library

26 build-depends: unix -any

27 exposed-modules: Data.Generics.Extras

28 Language.PureScript

29+ Language.PureScript.Constants

29 Language.PureScript.Options

30 Language.PureScript.Options

30 Language.PureScript.Declarations

31 Language.PureScript.Declarations

31 Language.PureScript.Kinds

32 Language.PureScript.Kinds

src/Language/PureScript.hs+5−3

@@ -30,6 +30,8 @@ import Language.PureScript.Options as P

30import Language.PureScript.ModuleDependencies as P

31import Language.PureScript.DeadCodeElimination as P

33+import qualified Language.PureScript.Constants as C

34+

33import Data.List (intercalate)

35import Data.List (intercalate)

34import Data.Maybe (mapMaybe)

36import Data.Maybe (mapMaybe)

35import Control.Monad.State.Lazy

37import Control.Monad.State.Lazy

@@ -69,9 +71,9 @@ compile opts ms = do

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

71 let exts = intercalate "\n" . map (`moduleToPs` env) $ elim

70 js' <- case mainModuleIdent of

72 js' <- case mainModuleIdent of

71 Just mmi -> do

73 Just mmi -> do

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

74+ when ((mmi, Ident C.main) `M.notMember` names env) $

73− Left $ show mmi ++ ".main is undefined"

75+ Left $ show mmi ++ "." ++ C.main ++ " is undefined"

74− return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]

76+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]

75 _ -> return js

77 _ -> return js

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

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

77 where

79 where

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

@@ -42,6 +42,7 @@ import Language.PureScript.Types

42import Language.PureScript.Optimizer

43import Language.PureScript.CodeGen.Common

44import Language.PureScript.Prim

45+import qualified Language.PureScript.Constants as C

46-- |

47-- |

47-- Generate code in the simplified Javascript intermediate representation for all declarations in a

48-- Generate code in the simplified Javascript intermediate representation for all declarations in a

@@ -51,9 +52,9 @@ moduleToJs :: Options -> Module -> Environment -> Maybe JS

51moduleToJs opts (Module name decls _) env =

52moduleToJs opts (Module name decls _) env =

52 case jsDecls of

53 case jsDecls of

53 [] -> Nothing

54 [] -> Nothing

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

55+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $

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

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

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

57+ [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar C._ps)) (JSObjectLiteral [])]

57 where

58 where

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

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

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

197-- variable that may have a qualified name.

198-- variable that may have a qualified name.

198--

199--

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

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

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

201+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar C._ps)

201qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

202qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

202

203

203-- |

204-- |

@@ -303,7 +304,7 @@ isOnlyConstructor m e ctor =

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

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

304

305

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

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

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

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

307 where

308 where

308 exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))

309 exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))

309 (JSAccessor "exports" (JSVar "module"))

310 (JSAccessor "exports" (JSVar "module"))

src/Language/PureScript/Constants.hsnew file+192

@@ -0,0 +1,192 @@

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

2+--

3+-- Module : Language.PureScript.Constants

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

5+-- License : MIT

6+--

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

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Various constants which refer to things in the Prelude

13+--

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

15+

16+module Language.PureScript.Constants where

17+

18+-- Prelude Operators

19+

20+($) :: String

21+($) = "$"

22+

23+(#) :: String

24+(#) = "#"

25+

26+(!!) :: String

27+(!!) = "!!"

28+

29+(++) :: String

30+(++) = "++"

31+

32+(>>=) :: String

33+(>>=) = ">>="

34+

35+(+) :: String

36+(+) = "+"

37+

38+(-) :: String

39+(-) = "-"

40+

41+(*) :: String

42+(*) = "*"

43+

44+(/) :: String

45+(/) = "/"

46+

47+(%) :: String

48+(%) = "%"

49+

50+(<) :: String

51+(<) = "<"

52+

53+(>) :: String

54+(>) = ">"

55+

56+(<=) :: String

57+(<=) = "<="

58+

59+(>=) :: String

60+(>=) = ">="

61+

62+(==) :: String

63+(==) = "=="

64+

65+(/=) :: String

66+(/=) = "/="

67+

68+(&) :: String

69+(&) = "&"

70+

71+bar :: String

72+bar = "|"

73+

74+(^) :: String

75+(^) = "^"

76+

77+(&&) :: String

78+(&&) = "&&"

79+

80+(||) :: String

81+(||) = "||"

82+

83+-- Prelude Operator Functions

84+

85+negate :: String

86+negate = "negate"

87+

88+shl :: String

89+shl = "shl"

90+

91+shr :: String

92+shr = "shr"

93+

94+zshr :: String

95+zshr = "zshr"

96+

97+complement :: String

98+complement = "complement"

99+

100+not :: String

101+not = "not"

102+

103+-- Prelude Values

104+

105+return :: String

106+return = "return"

107+

108+returnEscaped :: String

109+returnEscaped = "$return"

110+

111+untilE :: String

112+untilE = "untilE"

113+

114+whileE :: String

115+whileE = "whileE"

116+

117+runST :: String

118+runST = "runST"

119+

120+runSTArray :: String

121+runSTArray = "runSTArray"

122+

123+stRefValue :: String

124+stRefValue = "value"

125+

126+newSTRef :: String

127+newSTRef = "newSTRef"

128+

129+readSTRef :: String

130+readSTRef = "readSTRef"

131+

132+writeSTRef :: String

133+writeSTRef = "writeSTRef"

134+

135+modifySTRef :: String

136+modifySTRef = "modifySTRef"

137+

138+peekSTArray :: String

139+peekSTArray = "peekSTArray"

140+

141+pokeSTArray :: String

142+pokeSTArray = "pokeSTArray"

143+

144+-- Type Class Dictionary Names

145+

146+monadEffDictionary :: String

147+monadEffDictionary = "monadEff"

148+

149+numNumber :: String

150+numNumber = "numNumber"

151+

152+ordNumber :: String

153+ordNumber = "ordNumber"

154+

155+eqNumber :: String

156+eqNumber = "eqNumber"

157+

158+eqString :: String

159+eqString = "eqString"

160+

161+eqBoolean :: String

162+eqBoolean = "eqBoolean"

163+

164+bitsNumber :: String

165+bitsNumber = "bitsNumber"

166+

167+boolLikeBoolean :: String

168+boolLikeBoolean = "boolLikeBoolean"

169+

170+-- Main module

171+

172+main :: String

173+main = "main"

174+

175+-- Code Generation

176+

177+_ps :: String

178+_ps = "_ps"

179+

180+-- Modules

181+

182+prim :: String

183+prim = "Prim"

184+

185+prelude :: String

186+prelude = "Prelude"

187+

188+eff :: String

189+eff = "Control_Monad_Eff"

190+

191+st :: String

192+st = "Control_Monad_ST"

src/Language/PureScript/Optimizer.hs+5−4

@@ -39,6 +39,7 @@ module Language.PureScript.Optimizer (

40import Language.PureScript.CodeGen.JS.AST

41import Language.PureScript.Options

42+import qualified Language.PureScript.Constants as C

43import Language.PureScript.Optimizer.Common

44import Language.PureScript.Optimizer.Common

44import Language.PureScript.Optimizer.TCO

45import Language.PureScript.Optimizer.TCO

@@ -60,10 +61,10 @@ optimize opts | optionsNoOptimizations opts = id

60 , unThunk

61 , unThunk

61 , etaConvert

62 , etaConvert

62 , inlineVariables

63 , inlineVariables

63− , inlineOperator "$" $ \f x -> JSApp f [x]

64+ , inlineOperator (C.$) $ \f x -> JSApp f [x]

64− , inlineOperator "#" $ \x f -> JSApp f [x]

65+ , inlineOperator (C.#) $ \x f -> JSApp f [x]

65− , inlineOperator "!!" $ flip JSIndexer

66+ , inlineOperator (C.!!) $ flip JSIndexer

66− , inlineOperator "++" $ JSBinary Add

67+ , inlineOperator (C.++) $ JSBinary Add

67 , inlineCommonOperators ]

68 , inlineCommonOperators ]

69untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

70untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

src/Language/PureScript/Optimizer/Inliner.hs+48−33

@@ -28,6 +28,8 @@ import Language.PureScript.CodeGen.Common (identToJs)

28import Language.PureScript.Optimizer.Common

29import Language.PureScript.Names

31+import qualified Language.PureScript.Constants as C

32+

31shouldInline :: JS -> Bool

33shouldInline :: JS -> Bool

32shouldInline (JSVar _) = True

34shouldInline (JSVar _) = True

33shouldInline (JSNumericLiteral _) = True

35shouldInline (JSNumericLiteral _) = True

@@ -71,42 +73,46 @@ inlineOperator op f = everywhere (mkT convert)

71 convert :: JS -> JS

73 convert :: JS -> JS

72 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

74 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

73 convert other = other

75 convert other = other

74− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True

76+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

77+ _ps == C._ps &&

78+ longForm == identToJs (Op op) = True

75− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True

79+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

80+ _ps == C._ps &&

81+ op == op' = True

76 isOp _ = False

82 isOp _ = False

78inlineCommonOperators :: JS -> JS

84inlineCommonOperators :: JS -> JS

79inlineCommonOperators = applyAll

85inlineCommonOperators = applyAll

80− [ binary "numNumber" "+" Add

86+ [ binary C.numNumber (C.+) Add

81− , binary "numNumber" "-" Subtract

87+ , binary C.numNumber (C.-) Subtract

82− , binary "numNumber" "*" Multiply

88+ , binary C.numNumber (C.*) Multiply

83− , binary "numNumber" "/" Divide

89+ , binary C.numNumber (C./) Divide

84− , binary "numNumber" "%" Modulus

90+ , binary C.numNumber (C.%) Modulus

85− , unary "numNumber" "negate" Negate

91+ , unary C.numNumber C.negate Negate

87− , binary "ordNumber" "<" LessThan

93+ , binary C.ordNumber (C.<) LessThan

88− , binary "ordNumber" ">" GreaterThan

94+ , binary C.ordNumber (C.>) GreaterThan

89− , binary "ordNumber" "<=" LessThanOrEqualTo

95+ , binary C.ordNumber (C.<=) LessThanOrEqualTo

90− , binary "ordNumber" ">=" GreaterThanOrEqualTo

96+ , binary C.ordNumber (C.>=) GreaterThanOrEqualTo

92− , binary "eqNumber" "==" EqualTo

98+ , binary C.eqNumber (C.==) EqualTo

93− , binary "eqNumber" "/=" NotEqualTo

99+ , binary C.eqNumber (C./=) NotEqualTo

94− , binary "eqString" "==" EqualTo

100+ , binary C.eqString (C.==) EqualTo

95− , binary "eqString" "/=" NotEqualTo

101+ , binary C.eqString (C./=) NotEqualTo

96− , binary "eqBoolean" "==" EqualTo

102+ , binary C.eqBoolean (C.==) EqualTo

97− , binary "eqBoolean" "/=" NotEqualTo

103+ , binary C.eqBoolean (C./=) NotEqualTo

104

99− , binaryFunction "bitsNumber" "shl" ShiftLeft

105+ , binaryFunction C.bitsNumber C.shl ShiftLeft

100− , binaryFunction "bitsNumber" "shr" ShiftRight

106+ , binaryFunction C.bitsNumber C.shr ShiftRight

101− , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight

107+ , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight

102− , binary "bitsNumber" "&" BitwiseAnd

108+ , binary C.bitsNumber (C.&) BitwiseAnd

103− , binary "bitsNumber" "|" BitwiseOr

109+ , binary C.bitsNumber C.bar BitwiseOr

104− , binary "bitsNumber" "^" BitwiseXor

110+ , binary C.bitsNumber (C.^) BitwiseXor

105− , unary "bitsNumber" "complement" BitwiseNot

111+ , unary C.bitsNumber C.complement BitwiseNot

106

112

107− , binary "boolLikeBoolean" "&&" And

113+ , binary C.boolLikeBoolean (C.&&) And

108− , binary "boolLikeBoolean" "||" Or

114+ , binary C.boolLikeBoolean (C.||) Or

109− , unary "boolLikeBoolean" "not" Not

115+ , unary C.boolLikeBoolean C.not Not

110 ]

116 ]

111 where

117 where

112 binary :: String -> String -> BinaryOperator -> JS -> JS

118 binary :: String -> String -> BinaryOperator -> JS -> JS

@@ -115,8 +121,11 @@ inlineCommonOperators = applyAll

115 convert :: JS -> JS

121 convert :: JS -> JS

116 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

122 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

117 convert other = other

123 convert other = other

124+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&

118− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True

125+ longForm == identToJs (Op opString) = True

119− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True

126+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

127+ _ps == C._ps &&

128+ opString == op' = True

120 isOp _ = False

129 isOp _ = False

121 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

130 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

122 binaryFunction dictName fnName op = everywhere (mkT convert)

131 binaryFunction dictName fnName op = everywhere (mkT convert)

@@ -124,7 +133,9 @@ inlineCommonOperators = applyAll

124 convert :: JS -> JS

133 convert :: JS -> JS

125 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

134 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y

126 convert other = other

135 convert other = other

127− isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName == fnName' = True

136+ isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

137+ _ps == C._ps &&

138+ fnName == fnName' = True

128 isOp _ = False

139 isOp _ = False

129 unary :: String -> String -> UnaryOperator -> JS -> JS

140 unary :: String -> String -> UnaryOperator -> JS -> JS

130 unary dictName fnName op = everywhere (mkT convert)

141 unary dictName fnName op = everywhere (mkT convert)

@@ -132,7 +143,11 @@ inlineCommonOperators = applyAll

132 convert :: JS -> JS

143 convert :: JS -> JS

133 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

144 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x

134 convert other = other

145 convert other = other

135− isOp (JSAccessor fnName' (JSAccessor "Prelude" (JSVar "_ps"))) | fnName' == fnName = True

146+ isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

147+ _ps == C._ps &&

148+ fnName' == fnName = True

136 isOp _ = False

149 isOp _ = False

137− isOpDict dictName (JSApp (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == dictName = True

150+ isOpDict dictName (JSApp (JSAccessor prop (JSAccessor prelude (JSVar _ps))) [JSObjectLiteral []]) | prelude == C.prelude &&

151+ _ps == C._ps &&

152+ prop == dictName = True

138 isOpDict _ _ = False

153 isOpDict _ _ = False

src/Language/PureScript/Optimizer/MagicDo.hs+40−26

@@ -27,6 +27,8 @@ import Language.PureScript.CodeGen.JS.AST

27import Language.PureScript.CodeGen.Common (identToJs)

28import Language.PureScript.Names

30+import qualified Language.PureScript.Constants as C

31+

30magicDo :: Options -> JS -> JS

32magicDo :: Options -> JS -> JS

31magicDo opts | optionsMagicDo opts = inlineST . magicDo'

33magicDo opts | optionsMagicDo opts = inlineST . magicDo'

32 | otherwise = id

34 | otherwise = id

@@ -63,10 +65,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

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

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

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

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

65 -- Desugar untilE

67 -- Desugar untilE

66− convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =

68+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

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

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

68 -- Desugar whileE

70 -- Desugar whileE

69− convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc "whileE" f =

71+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

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

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

71 convert other = other

73 convert other = other

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

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

@@ -76,21 +78,31 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

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

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

77 isReturn _ = False

79 isReturn _ = False

78 -- Check if an expression represents the polymorphic >>= function

80 -- Check if an expression represents the polymorphic >>= function

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

81+ isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

82+ _ps == C._ps &&

83+ prop == identToJs (Op (C.>>=)) = True

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

84+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

85+ _ps == C._ps &&

86+ bind == (C.>>=) = True

81 isBindPoly _ = False

87 isBindPoly _ = False

82 -- Check if an expression represents the polymorphic return function

88 -- Check if an expression represents the polymorphic return function

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

89+ isRetPoly (JSAccessor returnEscaped (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

90+ _ps == C._ps &&

91+ returnEscaped == C.returnEscaped = True

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

92+ isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&

93+ _ps == C._ps &&

94+ return' == C.return = True

85 isRetPoly _ = False

95 isRetPoly _ = False

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

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

87− isEffFunc name (JSAccessor name' (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) | name == name' = True

97+ isEffFunc name (JSAccessor name' (JSAccessor eff (JSVar _ps))) | eff == C.eff &&

98+ _ps == C._ps &&

99+ name == name' = True

88 isEffFunc _ _ = False

100 isEffFunc _ _ = False

89− -- The name of the type class dictionary for the Monad Eff instance

90− effDictName = "monadEff"

91 -- Check if an expression represents the Monad Eff dictionary

101 -- Check if an expression represents the Monad Eff dictionary

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

102+ isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True

93− isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True

103+ isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&

104+ _ps == C._ps &&

105+ prop == C.monadEffDictionary = True

94 isEffDict _ = False

106 isEffDict _ = False

95 -- Remove __do function applications which remain after desugaring

107 -- Remove __do function applications which remain after desugaring

96 undo :: JS -> JS

108 undo :: JS -> JS

@@ -106,7 +118,7 @@ inlineST = everywhere (mkT convertBlock)

106 -- Look for runST blocks and inline the STRefs there.

118 -- Look for runST blocks and inline the STRefs there.

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

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

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

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

109− convertBlock (JSApp f [arg]) | isSTFunc "runST" f || isSTFunc "runSTArray" f =

121+ convertBlock (JSApp f [arg]) | isSTFunc C.runST f || isSTFunc C.runSTArray f =

110 let refs = nub . findSTRefsIn $ arg

122 let refs = nub . findSTRefsIn $ arg

111 usages = findAllSTUsagesIn arg

123 usages = findAllSTUsagesIn arg

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

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

@@ -116,32 +128,34 @@ inlineST = everywhere (mkT convertBlock)

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

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

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

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

118 -- agg(ressive) parameter.

130 -- agg(ressive) parameter.

119− convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =

131+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc C.newSTRef f =

120− if agg then arg else JSObjectLiteral [("value", arg)]

132+ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]

121− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =

133+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =

122− if agg then ref else JSAccessor "value" ref

134+ if agg then ref else JSAccessor C.stRefValue ref

123− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =

135+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =

124− if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg

136+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg

125− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =

137+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =

126− if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])

138+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])

127− convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =

139+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =

128 JSIndexer i arr

140 JSIndexer i arr

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

141+ convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc C.pokeSTArray f =

130 JSAssignment (JSIndexer i arr) val

142 JSAssignment (JSIndexer i arr) val

131 convert _ other = other

143 convert _ other = other

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

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

133− isSTFunc name (JSAccessor name' (JSAccessor "Control_Monad_ST" (JSVar "_ps"))) | name == name' = True

145+ isSTFunc name (JSAccessor name' (JSAccessor st (JSVar _ps))) | st == C.st &&

146+ _ps == C._ps &&

147+ name == name' = True

134 isSTFunc _ _ = False

148 isSTFunc _ _ = False

135 -- Find all ST Refs initialized in this block

149 -- Find all ST Refs initialized in this block

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

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

137 where

151 where

138− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]

152+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]

139 isSTRef _ = []

153 isSTRef _ = []

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

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

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

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

142 where

156 where

143− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]

157+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]

144− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]

158+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

145 isSTUsage _ = []

159 isSTUsage _ = []

146 -- Find all uses of a variable

160 -- Find all uses of a variable

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

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

src/Language/PureScript/Pretty/Values.hs+1−1

@@ -105,7 +105,7 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (

105 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

106 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

107 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

108− , [ Wrap ifThenElse $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintValue th ++ " : " ++ prettyPrintValue el ]

108+ , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

109 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

110 ]

111

src/Language/PureScript/Prim.hs+19−7

@@ -18,37 +18,51 @@ import Language.PureScript.Kinds

18import Language.PureScript.Names

19import Language.PureScript.Types

21+import qualified Language.PureScript.Constants as C

22+

21import qualified Data.Map as M

23import qualified Data.Map as M

25+-- |

26+-- Construct a ProperName in the Prim module

27+--

28+primName :: String -> Qualified ProperName

29+primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName

30+

31+-- |

32+-- Construct a type in the Prim module

33+--

34+primTy :: String -> Type

35+primTy = TypeConstructor . primName

36+

23-- |

37-- |

24-- Type constructor for functions

38-- Type constructor for functions

25--

39--

26tyFunction :: Type

40tyFunction :: Type

27−tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")

41+tyFunction = primTy "Function"

29-- |

43-- |

30-- Type constructor for strings

44-- Type constructor for strings

31--

45--

32tyString :: Type

46tyString :: Type

33−tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")

47+tyString = primTy "String"

35-- |

49-- |

36-- Type constructor for numbers

50-- Type constructor for numbers

37--

51--

38tyNumber :: Type

52tyNumber :: Type

39−tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")

53+tyNumber = primTy "Number"

41-- |

55-- |

42-- Type constructor for booleans

56-- Type constructor for booleans

43--

57--

44tyBoolean :: Type

58tyBoolean :: Type

45−tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")

59+tyBoolean = primTy "Boolean"

47-- |

61-- |

48-- Type constructor for arrays

62-- Type constructor for arrays

49--

63--

50tyArray :: Type

64tyArray :: Type

51−tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

65+tyArray = primTy "Array"

53-- |

67-- |

54-- Smart constructor for function types

68-- Smart constructor for function types

@@ -65,5 +79,3 @@ primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star)

65 , (primName "String" , Star)

79 , (primName "String" , Star)

66 , (primName "Number" , Star)

80 , (primName "Number" , Star)

67 , (primName "Boolean" , Star) ]

81 , (primName "Boolean" , Star) ]

68− where

69− primName name = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName name)

src/Language/PureScript/Sugar/DoNotation.hs+4−2

@@ -25,6 +25,8 @@ import Language.PureScript.Values

25import Language.PureScript.Names

26import Language.PureScript.Scope

28+import qualified Language.PureScript.Constants as C

29+

28-- |

30-- |

29-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

31-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

30-- and all @DoNotationLet@ constructors with let expressions.

32-- and all @DoNotationLet@ constructors with let expressions.

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

33desugarDo = everywhereM (mkM replace)

35desugarDo = everywhereM (mkM replace)

34 where

36 where

35 prelude :: ModuleName

37 prelude :: ModuleName

36− prelude = ModuleName [ProperName "Prelude"]

38+ prelude = ModuleName [ProperName C.prelude]

37 bind :: Value

39 bind :: Value

38− bind = Var (Qualified (Just prelude) (Op ">>="))

40+ bind = Var (Qualified (Just prelude) (Op (C.>>=)))

39 replace :: Value -> Either String Value

41 replace :: Value -> Either String Value

40 replace (Do els) = go els

42 replace (Do els) = go els

41 replace other = return other

43 replace other = return other

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

@@ -57,6 +57,7 @@ import Language.PureScript.TypeChecker.Kinds

57import Language.PureScript.TypeChecker.Synonyms

58import Language.PureScript.Pretty

59import Language.PureScript.Prim

60+import qualified Language.PureScript.Constants as C

61import Control.Monad.State

62import Control.Monad.State

62import Control.Monad.Error

63import Control.Monad.Error

@@ -197,7 +198,7 @@ typesOf mainModuleName moduleName vals = do

197 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

198 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

198 return (ident, (TypedValue True val'' ty, ty))

199 return (ident, (TypedValue True val'' ty, ty))

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

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

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

201+ when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do

201 [eff, a] <- replicateM 2 fresh

202 [eff, a] <- replicateM 2 fresh

202 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

203 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

203 -- Make sure unification variables do not escape

204 -- Make sure unification variables do not escape