git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Constants module #236
commit5bae73f1b7891e6090716873802df521993a238c authorPhil Freeman <paf31@cantab.net> dateThu 6 Mar 2014, 17:18 (13 years ago) parent74cdd72
11 files changed+322−81
compare with golang
unifiedsplit
purescript.cabal+1 src/Language/PureScript.hs+5−3 src/Language/PureScript/CodeGen/JS.hs+5−4 src/Language/PureScript/Constants.hs+192 src/Language/PureScript/Optimizer.hs+5−4 src/Language/PureScript/Optimizer/Inliner.hs+48−33 src/Language/PureScript/Optimizer/MagicDo.hs+40−26 src/Language/PureScript/Pretty/Values.hs+1−1 src/Language/PureScript/Prim.hs+19−7 src/Language/PureScript/Sugar/DoNotation.hs+4−2 src/Language/PureScript/TypeChecker/Types.hs+2−1
purescript.cabal+1
@@ -26,6 +26,7 @@ library
2626 build-depends: unix -any
2727 exposed-modules: Data.Generics.Extras
2828 Language.PureScript
29+ Language.PureScript.Constants
2930 Language.PureScript.Options
3031 Language.PureScript.Declarations
3132 Language.PureScript.Kinds
src/Language/PureScript.hs+5−3
@@ -30,6 +30,8 @@ import Language.PureScript.Options as P
3030import Language.PureScript.ModuleDependencies as P
3131import Language.PureScript.DeadCodeElimination as P
3232
33+import qualified Language.PureScript.Constants as C
34+
3335import Data.List (intercalate)
3436import Data.Maybe (mapMaybe)
3537import Control.Monad.State.Lazy
@@ -69,9 +71,9 @@ compile opts ms = do
6971 let exts = intercalate "\n" . map (`moduleToPs` env) $ elim
7072 js' <- case mainModuleIdent of
7173 Just mmi -> do
72− when ((mmi, Ident "main") `M.notMember` names env) $
73− Left $ show mmi ++ ".main is undefined"
74− return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]
74+ when ((mmi, Ident C.main) `M.notMember` names env) $
75+ Left $ show mmi ++ "." ++ C.main ++ " is undefined"
76+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
7577 _ -> return js
7678 return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)
7779 where
src/Language/PureScript/CodeGen/JS.hs+5−4
@@ -42,6 +42,7 @@ import Language.PureScript.Types
4242import Language.PureScript.Optimizer
4343import Language.PureScript.CodeGen.Common
4444import Language.PureScript.Prim
45+import qualified Language.PureScript.Constants as C
4546
4647-- |
4748-- Generate code in the simplified Javascript intermediate representation for all declarations in a
@@ -51,9 +52,9 @@ moduleToJs :: Options -> Module -> Environment -> Maybe JS
5152moduleToJs opts (Module name decls _) env =
5253 case jsDecls of
5354 [] -> Nothing
54− _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $
55+ _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $
5556 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 [])]
5758 where
5859 jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls
5960
@@ -197,7 +198,7 @@ varToJs m e qual@(Qualified _ ident) = go qual
197198-- variable that may have a qualified name.
198199--
199200qualifiedToJS :: 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)
201202qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
202203
203204-- |
@@ -303,7 +304,7 @@ isOnlyConstructor m e ctor =
303304 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
304305
305306wrapExportsContainer :: 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]
307308 where
308309 exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
309310 (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 (
3939
4040import Language.PureScript.CodeGen.JS.AST
4141import Language.PureScript.Options
42+import qualified Language.PureScript.Constants as C
4243
4344import Language.PureScript.Optimizer.Common
4445import Language.PureScript.Optimizer.TCO
@@ -60,10 +61,10 @@ optimize opts | optionsNoOptimizations opts = id
6061 , unThunk
6162 , etaConvert
6263 , inlineVariables
63− , inlineOperator "$" $ \f x -> JSApp f [x]
64− , inlineOperator "#" $ \x f -> JSApp f [x]
65− , inlineOperator "!!" $ flip JSIndexer
66− , inlineOperator "++" $ JSBinary Add
64+ , inlineOperator (C.$) $ \f x -> JSApp f [x]
65+ , inlineOperator (C.#) $ \x f -> JSApp f [x]
66+ , inlineOperator (C.!!) $ flip JSIndexer
67+ , inlineOperator (C.++) $ JSBinary Add
6768 , inlineCommonOperators ]
6869
6970untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
src/Language/PureScript/Optimizer/Inliner.hs+48−33
@@ -28,6 +28,8 @@ import Language.PureScript.CodeGen.Common (identToJs)
2828import Language.PureScript.Optimizer.Common
2929import Language.PureScript.Names
3030
31+import qualified Language.PureScript.Constants as C
32+
3133shouldInline :: JS -> Bool
3234shouldInline (JSVar _) = True
3335shouldInline (JSNumericLiteral _) = True
@@ -71,42 +73,46 @@ inlineOperator op f = everywhere (mkT convert)
7173 convert :: JS -> JS
7274 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
7375 convert other = other
74− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True
75− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True
76+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
77+ _ps == C._ps &&
78+ longForm == identToJs (Op op) = True
79+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
80+ _ps == C._ps &&
81+ op == op' = True
7682 isOp _ = False
7783
7884inlineCommonOperators :: JS -> JS
7985inlineCommonOperators = applyAll
80− [ binary "numNumber" "+" Add
81− , binary "numNumber" "-" Subtract
82− , binary "numNumber" "*" Multiply
83− , binary "numNumber" "/" Divide
84− , binary "numNumber" "%" Modulus
85− , unary "numNumber" "negate" Negate
86+ [ binary C.numNumber (C.+) Add
87+ , binary C.numNumber (C.-) Subtract
88+ , binary C.numNumber (C.*) Multiply
89+ , binary C.numNumber (C./) Divide
90+ , binary C.numNumber (C.%) Modulus
91+ , unary C.numNumber C.negate Negate
8692
87− , binary "ordNumber" "<" LessThan
88− , binary "ordNumber" ">" GreaterThan
89− , binary "ordNumber" "<=" LessThanOrEqualTo
90− , binary "ordNumber" ">=" GreaterThanOrEqualTo
93+ , binary C.ordNumber (C.<) LessThan
94+ , binary C.ordNumber (C.>) GreaterThan
95+ , binary C.ordNumber (C.<=) LessThanOrEqualTo
96+ , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
9197
92− , binary "eqNumber" "==" EqualTo
93− , binary "eqNumber" "/=" NotEqualTo
94− , binary "eqString" "==" EqualTo
95− , binary "eqString" "/=" NotEqualTo
96− , binary "eqBoolean" "==" EqualTo
97− , binary "eqBoolean" "/=" NotEqualTo
98+ , binary C.eqNumber (C.==) EqualTo
99+ , binary C.eqNumber (C./=) NotEqualTo
100+ , binary C.eqString (C.==) EqualTo
101+ , binary C.eqString (C./=) NotEqualTo
102+ , binary C.eqBoolean (C.==) EqualTo
103+ , binary C.eqBoolean (C./=) NotEqualTo
98104
99− , binaryFunction "bitsNumber" "shl" ShiftLeft
100− , binaryFunction "bitsNumber" "shr" ShiftRight
101− , binaryFunction "bitsNumber" "zshr" ZeroFillShiftRight
102− , binary "bitsNumber" "&" BitwiseAnd
103− , binary "bitsNumber" "|" BitwiseOr
104− , binary "bitsNumber" "^" BitwiseXor
105− , unary "bitsNumber" "complement" BitwiseNot
105+ , binaryFunction C.bitsNumber C.shl ShiftLeft
106+ , binaryFunction C.bitsNumber C.shr ShiftRight
107+ , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
108+ , binary C.bitsNumber (C.&) BitwiseAnd
109+ , binary C.bitsNumber C.bar BitwiseOr
110+ , binary C.bitsNumber (C.^) BitwiseXor
111+ , unary C.bitsNumber C.complement BitwiseNot
106112
107− , binary "boolLikeBoolean" "&&" And
108− , binary "boolLikeBoolean" "||" Or
109− , unary "boolLikeBoolean" "not" Not
113+ , binary C.boolLikeBoolean (C.&&) And
114+ , binary C.boolLikeBoolean (C.||) Or
115+ , unary C.boolLikeBoolean C.not Not
110116 ]
111117 where
112118 binary :: String -> String -> BinaryOperator -> JS -> JS
@@ -115,8 +121,11 @@ inlineCommonOperators = applyAll
115121 convert :: JS -> JS
116122 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
117123 convert other = other
118− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True
119− isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True
124+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&
125+ longForm == identToJs (Op opString) = True
126+ isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
127+ _ps == C._ps &&
128+ opString == op' = True
120129 isOp _ = False
121130 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
122131 binaryFunction dictName fnName op = everywhere (mkT convert)
@@ -124,7 +133,9 @@ inlineCommonOperators = applyAll
124133 convert :: JS -> JS
125134 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
126135 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
128139 isOp _ = False
129140 unary :: String -> String -> UnaryOperator -> JS -> JS
130141 unary dictName fnName op = everywhere (mkT convert)
@@ -132,7 +143,11 @@ inlineCommonOperators = applyAll
132143 convert :: JS -> JS
133144 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
134145 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
136149 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
138153 isOpDict _ _ = False
src/Language/PureScript/Optimizer/MagicDo.hs+40−26
@@ -27,6 +27,8 @@ import Language.PureScript.CodeGen.JS.AST
2727import Language.PureScript.CodeGen.Common (identToJs)
2828import Language.PureScript.Names
2929
30+import qualified Language.PureScript.Constants as C
31+
3032magicDo :: Options -> JS -> JS
3133magicDo opts | optionsMagicDo opts = inlineST . magicDo'
3234 | otherwise = id
@@ -63,10 +65,10 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
6365 convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
6466 JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
6567 -- Desugar untilE
66− convert (JSApp (JSApp f [arg]) []) | isEffFunc "untilE" f =
68+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
6769 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
6870 -- 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 =
7072 JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn (JSObjectLiteral []) ])) []
7173 convert other = other
7274 -- Check if an expression represents a monomorphic call to >>= for the Eff monad
@@ -76,21 +78,31 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
7678 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict effDict = True
7779 isReturn _ = False
7880 -- Check if an expression represents the polymorphic >>= function
79− isBindPoly (JSAccessor prop (JSAccessor "Prelude" (JSVar "_ps"))) | prop == identToJs (Op ">>=") = True
80− isBindPoly (JSIndexer (JSStringLiteral ">>=") (JSAccessor "Prelude" (JSVar "_ps"))) = True
81+ isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
82+ _ps == C._ps &&
83+ prop == identToJs (Op (C.>>=)) = True
84+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
85+ _ps == C._ps &&
86+ bind == (C.>>=) = True
8187 isBindPoly _ = False
8288 -- Check if an expression represents the polymorphic return function
83− isRetPoly (JSAccessor "$return" (JSAccessor "Prelude" (JSVar "_ps"))) = True
84− isRetPoly (JSIndexer (JSStringLiteral "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
92+ isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
93+ _ps == C._ps &&
94+ return' == C.return = True
8595 isRetPoly _ = False
8696 -- 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
88100 isEffFunc _ _ = False
89− -- The name of the type class dictionary for the Monad Eff instance
90− effDictName = "monadEff"
91101 -- Check if an expression represents the Monad Eff dictionary
92− isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == effDictName = True
93− isEffDict (JSApp (JSAccessor prop (JSAccessor "Control_Monad_Eff" (JSVar "_ps"))) [JSObjectLiteral []]) | prop == effDictName = True
102+ isEffDict (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == C.monadEffDictionary = True
103+ isEffDict (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
104+ _ps == C._ps &&
105+ prop == C.monadEffDictionary = True
94106 isEffDict _ = False
95107 -- Remove __do function applications which remain after desugaring
96108 undo :: JS -> JS
@@ -106,7 +118,7 @@ inlineST = everywhere (mkT convertBlock)
106118 -- Look for runST blocks and inline the STRefs there.
107119 -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
108120 -- 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 =
110122 let refs = nub . findSTRefsIn $ arg
111123 usages = findAllSTUsagesIn arg
112124 allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
@@ -116,32 +128,34 @@ inlineST = everywhere (mkT convertBlock)
116128 -- Convert a block in a safe way, preserving object wrappers of references,
117129 -- or in a more aggressive way, turning wrappers into local variables depending on the
118130 -- agg(ressive) parameter.
119− convert agg (JSApp (JSApp f [arg]) []) | isSTFunc "newSTRef" f =
120− if agg then arg else JSObjectLiteral [("value", arg)]
121− convert agg (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f =
122− if agg then ref else JSAccessor "value" ref
123− convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc "writeSTRef" f =
124− if agg then JSAssignment ref arg else JSAssignment (JSAccessor "value" ref) arg
125− convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =
126− if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])
127− convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =
131+ convert agg (JSApp (JSApp f [arg]) []) | isSTFunc C.newSTRef f =
132+ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]
133+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
134+ if agg then ref else JSAccessor C.stRefValue ref
135+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
136+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
137+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
138+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
139+ convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc C.peekSTArray f =
128140 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 =
130142 JSAssignment (JSIndexer i arr) val
131143 convert _ other = other
132144 -- 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
134148 isSTFunc _ _ = False
135149 -- Find all ST Refs initialized in this block
136150 findSTRefsIn = everything (++) (mkQ [] isSTRef)
137151 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]
139153 isSTRef _ = []
140154 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
141155 findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)
142156 where
143− isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc "readSTRef" f = [ref]
144− isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc "writeSTRef" f || isSTFunc "modifySTRef" f = [ref]
157+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
158+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
145159 isSTUsage _ = []
146160 -- Find all uses of a variable
147161 appearingIn ref = everything (++) (mkQ [] isVar)
src/Language/PureScript/Pretty/Values.hs+1−1
@@ -105,7 +105,7 @@ prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue (
105105 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
106106 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
107107 , [ 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 ]
109109 , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]
110110 ]
111111
src/Language/PureScript/Prim.hs+19−7
@@ -18,37 +18,51 @@ import Language.PureScript.Kinds
1818import Language.PureScript.Names
1919import Language.PureScript.Types
2020
21+import qualified Language.PureScript.Constants as C
22+
2123import qualified Data.Map as M
2224
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+
2337-- |
2438-- Type constructor for functions
2539--
2640tyFunction :: Type
27−tyFunction = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Function")
41+tyFunction = primTy "Function"
2842
2943-- |
3044-- Type constructor for strings
3145--
3246tyString :: Type
33−tyString = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "String")
47+tyString = primTy "String"
3448
3549-- |
3650-- Type constructor for numbers
3751--
3852tyNumber :: Type
39−tyNumber = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Number")
53+tyNumber = primTy "Number"
4054
4155-- |
4256-- Type constructor for booleans
4357--
4458tyBoolean :: Type
45−tyBoolean = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Boolean")
59+tyBoolean = primTy "Boolean"
4660
4761-- |
4862-- Type constructor for arrays
4963--
5064tyArray :: Type
51−tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
65+tyArray = primTy "Array"
5266
5367-- |
5468-- Smart constructor for function types
@@ -65,5 +79,3 @@ primTypes = M.fromList [ (primName "Function" , FunKind Star (FunKind Star Star)
6579 , (primName "String" , Star)
6680 , (primName "Number" , Star)
6781 , (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
2525import Language.PureScript.Names
2626import Language.PureScript.Scope
2727
28+import qualified Language.PureScript.Constants as C
29+
2830-- |
2931-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
3032-- and all @DoNotationLet@ constructors with let expressions.
@@ -33,9 +35,9 @@ desugarDo :: (Data d) => d -> Either String d
3335desugarDo = everywhereM (mkM replace)
3436 where
3537 prelude :: ModuleName
36− prelude = ModuleName [ProperName "Prelude"]
38+ prelude = ModuleName [ProperName C.prelude]
3739 bind :: Value
38− bind = Var (Qualified (Just prelude) (Op ">>="))
40+ bind = Var (Qualified (Just prelude) (Op (C.>>=)))
3941 replace :: Value -> Either String Value
4042 replace (Do els) = go els
4143 replace other = return other
src/Language/PureScript/TypeChecker/Types.hs+2−1
@@ -57,6 +57,7 @@ import Language.PureScript.TypeChecker.Kinds
5757import Language.PureScript.TypeChecker.Synonyms
5858import Language.PureScript.Pretty
5959import Language.PureScript.Prim
60+import qualified Language.PureScript.Constants as C
6061
6162import Control.Monad.State
6263import Control.Monad.Error
@@ -197,7 +198,7 @@ typesOf mainModuleName moduleName vals = do
197198 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
198199 return (ident, (TypedValue True val'' ty, ty))
199200 -- 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
201202 [eff, a] <- replicateM 2 fresh
202203 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
203204 -- Make sure unification variables do not escape