8927254 · rowtype-yoga/purescript-native

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

Remove `Ident` from JS AST

commit8927254bd4ab4ec57faa3ceb034dfa1382f327d0 authorGary Burgess <garyb@users.noreply.github.com> dateTue 4 Feb 2014, 00:23 (13 years ago) parenteb34595

12 files changed+147−137

compare with golang

unifiedsplit

purescript.cabal+1

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

3636 Language.PureScript.Sugar.Operators

3737 Language.PureScript.Sugar.TypeClasses

3838 Language.PureScript.CodeGen

39+ Language.PureScript.CodeGen.Common

3940 Language.PureScript.CodeGen.Externs

4041 Language.PureScript.CodeGen.JS

4142 Language.PureScript.CodeGen.JS.AST

src/Language/PureScript.hs+1−1

@@ -65,6 +65,6 @@ compile opts ms = do

6565 _ | optionsRunMain opts -> do

6666 when ((ModuleName (ProperName "Main"), Ident "main") `M.notMember` (names env)) $

6767 Left "Main.main is undefined"

68− return $ js ++ [JSApp (JSAccessor "main" (JSVar (Ident "Main"))) []]

68+ return $ js ++ [JSApp (JSAccessor "main" (JSVar "Main")) []]

6969 | otherwise -> return js

7070 return (prettyPrintJS js', exts, env)

src/Language/PureScript/CodeGen/Common.hsnew file+56

@@ -0,0 +1,56 @@

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

2+--

3+-- Module : Language.PureScript.CodeGen.Common

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+-- Common code generation utility functions

13+--

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

15+

16+module Language.PureScript.CodeGen.Common where

17+

18+import Data.Char

19+import Language.PureScript.Names

20+

21+-- |

22+-- Convert an Ident into a valid Javascript identifier:

23+--

24+-- * Alphanumeric characters are kept unmodified

25+--

26+-- * Symbols are encoded as a dollar symbol ($) followed by their ordinal value

27+--

28+identToJs :: Ident -> String

29+identToJs (Ident name) = concatMap identCharToString name

30+identToJs (Op op) = concatMap identCharToString op

31+identToJs (Escaped name) = name

32+

33+identCharToString :: Char -> String

34+identCharToString c | isAlphaNum c = [c]

35+identCharToString '_' = "_"

36+identCharToString '.' = "$dot"

37+identCharToString '$' = "$dollar"

38+identCharToString '~' = "$tilde"

39+identCharToString '=' = "$eq"

40+identCharToString '<' = "$less"

41+identCharToString '>' = "$greater"

42+identCharToString '!' = "$bang"

43+identCharToString '#' = "$hash"

44+identCharToString '%' = "$percent"

45+identCharToString '^' = "$up"

46+identCharToString '&' = "$amp"

47+identCharToString '|' = "$bar"

48+identCharToString '*' = "$times"

49+identCharToString '/' = "$div"

50+identCharToString '+' = "$plus"

51+identCharToString '-' = "$minus"

52+identCharToString ':' = "$colon"

53+identCharToString '\\' = "$bslash"

54+identCharToString '?' = "$qmark"

55+identCharToString '@' = "$at"

56+identCharToString c = '$' : show (ord c)

src/Language/PureScript/CodeGen/JS.hs+36−32

@@ -41,6 +41,7 @@ import Language.PureScript.Options

4141import Language.PureScript.CodeGen.JS.AST as AST

4242import Language.PureScript.Types

4343import Language.PureScript.CodeGen.Optimize

44+import Language.PureScript.CodeGen.Common (identToJs)

4445import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

4546

4647-- |

@@ -48,11 +49,11 @@ import Language.PureScript.TypeChecker.Monad (canonicalizeDataConstructor)

4849--

4950moduleToJs :: Options -> Module -> Environment -> [JS]

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

51− [ JSVariableIntroduction (Ident name) Nothing

52− , JSApp (JSFunction Nothing [Ident name]

52+ [ JSVariableIntroduction name Nothing

53+ , JSApp (JSFunction Nothing [name]

5354 (JSBlock (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts (ModuleName pname) decl env) (sortBy typeClassesLast decls))))

54− [JSAssignment (JSAssignVariable (Ident name))

55− (JSBinary Or (JSVar (Ident name)) (JSObjectLiteral []))]

55+ [JSAssignment (JSAssignVariable name)

56+ (JSBinary Or (JSVar name) (JSObjectLiteral []))]

5657 ]

5758 where

5859 typeClassesLast (ExternDeclaration TypeClassDictionaryImport _ _ _) (ExternDeclaration TypeClassDictionaryImport _ _ _) = EQ

@@ -65,33 +66,36 @@ moduleToJs opts (Module pname@(ProperName name) decls) env =

6566--

6667declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

6768declToJs opts mp (ValueDeclaration ident _ _ val) e =

68− Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

69− setProperty (identToJs ident) (JSVar ident) mp ]

69+ Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val)),

70+ setProperty (identToJs ident) (var ident) mp ]

7071declToJs opts mp (BindingGroupDeclaration vals) e =

7172 Just $ concatMap (\(ident, val) ->

72− [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),

73− setProperty (identToJs ident) (JSVar ident) mp ]

73+ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val)),

74+ setProperty (identToJs ident) (var ident) mp ]

7475 ) vals

7576declToJs _ mp (DataDeclaration _ _ ctors) _ =

7677 Just $ flip concatMap ctors $ \(pn@(ProperName ctor), maybeTy) ->

7778 let

7879 ctorJs =

7980 case maybeTy of

80− Nothing -> JSVariableIntroduction (Ident ctor) (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))

81− Just _ -> JSFunction (Just (Ident ctor)) [Ident "value"]

81+ Nothing -> JSVariableIntroduction ctor (Just (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))) ]))

82+ Just _ -> JSFunction (Just ctor) ["value"]

8283 (JSBlock [JSReturn

8384 (JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn)))

84− , ("value", JSVar (Ident "value")) ])])

85− in [ ctorJs, setProperty ctor (JSVar (Ident ctor)) mp ]

85+ , ("value", JSVar "value") ])])

86+ in [ ctorJs, setProperty ctor (JSVar ctor) mp ]

8687declToJs opts mp (DataBindingGroupDeclaration ds) e =

8788 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

8889declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =

8990 Just [ js

90− , setProperty (identToJs ident) (JSVar ident) mp ]

91+ , setProperty (identToJs ident) (var ident) mp ]

9192declToJs _ _ _ _ = Nothing

9293

9394setProperty :: String -> JS -> ModuleName -> JS

94−setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable (Ident moduleName))) val

95+setProperty prop val (ModuleName (ProperName moduleName)) = JSAssignment (JSAssignProperty prop (JSAssignVariable moduleName)) val

96+

97+var :: Ident -> JS

98+var name = JSVar $ identToJs name

9599

96100valueToJs :: Options -> ModuleName -> Environment -> Value -> JS

97101valueToJs _ _ _ (NumericLiteral n) = JSNumericLiteral n

@@ -99,11 +103,11 @@ valueToJs _ _ _ (StringLiteral s) = JSStringLiteral s

99103valueToJs _ _ _ (BooleanLiteral b) = JSBooleanLiteral b

100104valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral (map (valueToJs opts m e) xs)

101105valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral (map (second (valueToJs opts m e)) ps)

102−valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar (Ident "Object"))) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

106+valueToJs opts m e (ObjectUpdate o ps) = JSApp (JSAccessor "extend" (JSVar "Object")) [ valueToJs opts m e o, JSObjectLiteral (map (second (valueToJs opts m e)) ps)]

103107valueToJs _ m e (Constructor (Qualified Nothing name)) =

104108 case M.lookup (m, name) (dataConstructors e) of

105109 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

106− _ -> JSVar . Ident . runProperName $ name

110+ _ -> JSVar . runProperName $ name

107111valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

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

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

@@ -111,8 +115,8 @@ valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e c

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

112116valueToJs opts m e (Indexer index val) = JSIndexer (valueToJs opts m e index) (valueToJs opts m e val)

113117valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]

114−valueToJs opts m e (Abs arg val) = JSFunction Nothing [arg] (JSBlock [JSReturn (valueToJs opts m e val)])

115−valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = JSFunction Nothing [arg] (JSBlock $ runtimeTypeChecks arg ty ++ [JSReturn (valueToJs opts m e val)])

118+valueToJs opts m e (Abs arg val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m e val)])

119+valueToJs opts m e (TypedValue _ (Abs arg val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])

116120valueToJs opts m e (Unary op val) = JSUnary op (valueToJs opts m e val)

117121valueToJs opts m e (Binary op v1 v2) = JSBinary op (valueToJs opts m e v1) (valueToJs opts m e v2)

118122valueToJs _ m e (Var ident) = varToJs m e ident

@@ -120,7 +124,7 @@ valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

120124valueToJs _ _ _ (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

121125valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

122126

123−runtimeTypeChecks :: Ident -> Type -> [JS]

127+runtimeTypeChecks :: String -> Type -> [JS]

124128runtimeTypeChecks arg ty =

125129 let

126130 argTy = getFunctionArgumentType ty

@@ -147,14 +151,14 @@ runtimeTypeChecks arg ty =

147151 typeCheck :: JS -> String -> JS

148152 typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing

149153 arrayCheck :: JS -> JS

150− arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar (Ident "Array"))) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

154+ arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing

151155

152156varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

153157varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of

154− Just (_, ty) | isExtern ty -> JSVar ident

158+ Just (_, ty) | isExtern ty -> var ident

155159 Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)

156160 _ -> case qual of

157− Qualified Nothing _ -> JSVar ident

161+ Qualified Nothing _ -> var ident

158162 _ -> qualifiedToJS identToJs qual

159163 where

160164 isExtern (Extern ForeignImport) = True

@@ -164,17 +168,17 @@ varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e)

164168 isExtern _ = False

165169

166170qualifiedToJS :: (a -> String) -> Qualified a -> JS

167−qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar (Ident m))

168−qualifiedToJS f (Qualified Nothing a) = JSVar (Ident (f a))

171+qualifiedToJS f (Qualified (Just (ModuleName (ProperName m))) a) = JSAccessor (f a) (JSVar m)

172+qualifiedToJS f (Qualified Nothing a) = JSVar (f a)

169173

170174bindersToJs :: Options -> ModuleName -> Environment -> [([Binder], Maybe Guard, Value)] -> [JS] -> JS

171−bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do

175+bindersToJs opts m e binders vals = runGen (map identToJs (unusedNames (binders, vals))) $ do

172176 valNames <- replicateM (length vals) fresh

173177 jss <- forM binders $ \(bs, grd, result) -> go valNames [JSReturn (valueToJs opts m e result)] bs grd

174178 return $ JSApp (JSFunction Nothing valNames (JSBlock (concat jss ++ [JSThrow (JSStringLiteral "Failed pattern match")])))

175179 vals

176180 where

177− go :: [Ident] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

181+ go :: [String] -> [JS] -> [Binder] -> Maybe Guard -> Gen [JS]

178182 go _ done [] Nothing = return done

179183 go _ done [] (Just cond) = return [JSIfElse (valueToJs opts m e cond) (JSBlock done) Nothing]

180184 go (v:vs) done' (b:bs) grd = do

@@ -182,7 +186,7 @@ bindersToJs opts m e binders vals = runGen (unusedNames (binders, vals)) $ do

182186 binderToJs m e v done'' b

183187 go _ _ _ _ = error "Invalid arguments to bindersToJs"

184188

185−binderToJs :: ModuleName -> Environment -> Ident -> [JS] -> Binder -> Gen [JS]

189+binderToJs :: ModuleName -> Environment -> String -> [JS] -> Binder -> Gen [JS]

186190binderToJs _ _ _ done NullBinder = return done

187191binderToJs _ _ varName done (StringBinder str) =

188192 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

@@ -193,7 +197,7 @@ binderToJs _ _ varName done (BooleanBinder True) =

193197binderToJs _ _ varName done (BooleanBinder False) =

194198 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

195199binderToJs _ _ varName done (VarBinder ident) =

196− return (JSVariableIntroduction ident (Just (JSVar varName)) : done)

200+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

197201binderToJs m e varName done (NullaryBinder ctor) =

198202 if isOnlyConstructor m e ctor

199203 then

@@ -243,7 +247,7 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

243247 )) Nothing]

244248binderToJs m e varName done (NamedBinder ident binder) = do

245249 js <- binderToJs m e varName done binder

246− return (JSVariableIntroduction ident (Just (JSVar varName)) : js)

250+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

247251

248252isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool

249253isOnlyConstructor m e ctor =

@@ -258,10 +262,10 @@ isOnlyConstructor m e ctor =

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

259263

260264statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS

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

262−statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable target) (valueToJs opts m e value)

265+statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction (identToJs ident) (Just (valueToJs opts m e value))

266+statementToJs opts m e (Assignment target value) = JSAssignment (JSAssignVariable (identToJs target)) (valueToJs opts m e value)

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

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

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

265269statementToJs opts m e (If ifst) = ifToJs ifst

266270 where

267271 ifToJs :: IfStatement -> JS

src/Language/PureScript/CodeGen/JS/AST.hs+5−6

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

1717

1818module Language.PureScript.CodeGen.JS.AST where

1919

20−import Language.PureScript.Names

2120import Language.PureScript.Values

2221

2322import Data.Data

@@ -65,7 +64,7 @@ data JS

6564 -- |

6665 -- A function introduction (optional name, arguments, body)

6766 --

68− | JSFunction (Maybe Ident) [Ident] JS

67+ | JSFunction (Maybe String) [String] JS

6968 -- |

7069 -- Function application

7170 --

@@ -73,7 +72,7 @@ data JS

7372 -- |

7473 -- Variable

7574 --

76− | JSVar Ident

75+ | JSVar String

7776 -- |

7877 -- Conditional expression

7978 --

@@ -85,7 +84,7 @@ data JS

8584 -- |

8685 -- A variable introduction and optional initialization

8786 --

88− | JSVariableIntroduction Ident (Maybe JS)

87+ | JSVariableIntroduction String (Maybe JS)

8988 -- |

9089 -- A variable assignment

9190 --

@@ -97,7 +96,7 @@ data JS

9796 -- |

9897 -- For loop

9998 --

100− | JSFor Ident JS JS JS

99+ | JSFor String JS JS JS

101100 -- |

102101 -- If-then-else statement

103102 --

@@ -138,7 +137,7 @@ data JSAssignment

138137 -- |

139138 -- Assign a variable

140139 --

141− = JSAssignVariable Ident

140+ = JSAssignVariable String

142141 -- |

143142 -- Assign an object property

144143 --

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

@@ -26,18 +26,18 @@ import Language.PureScript.Names

2626-- |

2727-- Code generation monad data type

2828--

29−newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident])

29+newtype Gen a = Gen { unGen :: State [String] a } deriving (Functor, Applicative, Monad, MonadState [String])

3030

3131-- |

3232-- Run a computation in the code generation monad

3333--

34−runGen :: [Ident] -> Gen a -> a

34+runGen :: [String] -> Gen a -> a

3535runGen names = flip evalState names . unGen

3636

3737-- |

3838-- Generate a fresh name

3939--

40−fresh :: Gen Ident

40+fresh :: Gen String

4141fresh = do

4242 (s:ss) <- get

4343 put ss

src/Language/PureScript/CodeGen/Optimize.hs+24−26

@@ -42,7 +42,7 @@ import Data.Generics

4242import Language.PureScript.Names

4343import Language.PureScript.CodeGen.JS.AST

4444import Language.PureScript.Options

45−import Language.PureScript.Pretty.Common (identToJs)

45+import Language.PureScript.CodeGen.Common (identToJs)

4646import Language.PureScript.Sugar.TypeClasses

4747 (mkDictionaryValueName)

4848import Language.PureScript.Types (Type(..))

@@ -70,19 +70,19 @@ untilFixedPoint f a = go a

7070 go a' = let a'' = f a' in

7171 if a'' == a' then a'' else go a''

7272

73−replaceIdent :: (Data d) => Ident -> JS -> d -> d

73+replaceIdent :: (Data d) => String -> JS -> d -> d

7474replaceIdent var1 js = everywhere (mkT replace)

7575 where

7676 replace (JSVar var2) | var1 == var2 = js

7777 replace other = other

7878

79−replaceIdents :: (Data d) => [(Ident, JS)] -> d -> d

79+replaceIdents :: (Data d) => [(String, JS)] -> d -> d

8080replaceIdents vars = everywhere (mkT replace)

8181 where

8282 replace v@(JSVar var) = fromMaybe v $ lookup var vars

8383 replace other = other

8484

85−isReassigned :: (Data d) => Ident -> d -> Bool

85+isReassigned :: (Data d) => String -> d -> Bool

8686isReassigned var1 = everything (||) (mkQ False check)

8787 where

8888 check :: JS -> Bool

@@ -97,7 +97,7 @@ isRebound js d = any (\var -> isReassigned var d) (variablesOf js)

9797 variablesOf (JSIndexer index val) = variablesOf index ++ variablesOf val

9898 variablesOf _ = []

9999

100−isUsed :: (Data d) => Ident -> d -> Bool

100+isUsed :: (Data d) => String -> d -> Bool

101101isUsed var1 = everything (||) (mkQ False check)

102102 where

103103 check :: JS -> Bool

@@ -105,11 +105,11 @@ isUsed var1 = everything (||) (mkQ False check)

105105 check (JSAssignment target _) | var1 == targetVariable target = True

106106 check _ = False

107107

108−targetVariable :: JSAssignment -> Ident

108+targetVariable :: JSAssignment -> String

109109targetVariable (JSAssignVariable var) = var

110110targetVariable (JSAssignProperty _ tgt) = targetVariable tgt

111111

112−isUpdated :: (Data d) => Ident -> d -> Bool

112+isUpdated :: (Data d) => String -> d -> Bool

113113isUpdated var1 = everything (||) (mkQ False check)

114114 where

115115 check :: JS -> Bool

@@ -173,12 +173,10 @@ tco' = everywhere (mkT convert)

173173 where

174174 tcoLabel :: String

175175 tcoLabel = "tco"

176− tcoVar :: Ident -> Ident

177− tcoVar (Ident arg) = Ident $ "__tco_" ++ arg

178− tcoVar _ = error "Invalid name in tcoVar"

179− copyVar :: Ident -> Ident

180− copyVar (Ident arg) = Ident $ "__copy_" ++ arg

181− copyVar _ = error "Invalid name in copyVar"

176+ tcoVar :: String -> String

177+ tcoVar arg = "__tco_" ++ arg

178+ copyVar :: String -> String

179+ copyVar arg = "__copy_" ++ arg

182180 convert :: JS -> JS

183181 convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =

184182 let

@@ -191,7 +189,7 @@ tco' = everywhere (mkT convert)

191189 JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

192190 | otherwise -> js

193191 convert js = js

194− collectAllFunctionArgs :: [[Ident]] -> (JS -> JS) -> JS -> ([[Ident]], JS, JS -> JS)

192+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

195193 collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

196194 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

197195 collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

@@ -201,7 +199,7 @@ tco' = everywhere (mkT convert)

201199 collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

202200 (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))

203201 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

204− isTailCall :: Ident -> JS -> Bool

202+ isTailCall :: String -> JS -> Bool

205203 isTailCall ident js =

206204 let

207205 numSelfCalls = everything (+) (mkQ 0 countSelfCalls) js

@@ -220,7 +218,7 @@ tco' = everywhere (mkT convert)

220218 countSelfCallsInTailPosition _ = 0

221219 countSelfCallsUnderFunctions (JSFunction _ _ js') = everything (+) (mkQ 0 countSelfCalls) js'

222220 countSelfCallsUnderFunctions _ = 0

223− toLoop :: Ident -> [Ident] -> JS -> JS

221+ toLoop :: String -> [String] -> JS -> JS

224222 toLoop ident allArgs js = JSBlock $

225223 map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

226224 [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhere (mkT loopify) js ]) ]

@@ -239,7 +237,7 @@ tco' = everywhere (mkT convert)

239237 collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

240238 collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

241239 collectSelfCallArgs allArgumentValues _ = allArgumentValues

242− isSelfCall :: Ident -> JS -> Bool

240+ isSelfCall :: String -> JS -> Bool

243241 isSelfCall ident (JSApp (JSVar ident') _) | ident == ident' = True

244242 isSelfCall ident (JSApp fn _) = isSelfCall ident fn

245243 isSelfCall _ _ = False

@@ -251,10 +249,10 @@ magicDo opts | optionsMagicDo opts = magicDo'

251249magicDo' :: JS -> JS

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

253251 where

254− fnName = Ident "__do"

252+ fnName = "__do"

255253 convert :: JS -> JS

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

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

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

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

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

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

@@ -263,11 +261,11 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

263261 isBind _ = False

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

265263 isReturn _ = False

266− isBindPoly (JSVar (Op ">>=")) = True

267− isBindPoly (JSAccessor prop (JSVar (Ident "Prelude"))) | prop == identToJs (Op ">>=") = True

264+ isBindPoly (JSVar op) | op == identToJs (Op ">>=") = True

265+ isBindPoly (JSAccessor prop (JSVar "Prelude")) | prop == identToJs (Op ">>=") = True

268266 isBindPoly _ = False

269− isRetPoly (JSVar (Ident "ret")) = True

270− isRetPoly (JSAccessor "ret" (JSVar (Ident "Prelude"))) = True

267+ isRetPoly (JSVar "ret") = True

268+ isRetPoly (JSAccessor "ret" (JSVar "Prelude")) = True

271269 isRetPoly _ = False

272270 prelude = ModuleName (ProperName "Prelude")

273271 effModule = ModuleName (ProperName "Eff")

@@ -275,8 +273,8 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

275273 effModule

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

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

278− isEffDict (JSVar (Ident ident)) | ident == effDictName = True

279− isEffDict (JSAccessor prop (JSVar (Ident "Eff"))) | prop == effDictName = True

276+ isEffDict (JSVar ident) | ident == effDictName = True

277+ isEffDict (JSAccessor prop (JSVar "Eff")) | prop == effDictName = True

280278 isEffDict _ = False

281279 undo :: JS -> JS

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

@@ -298,5 +296,5 @@ inlineDollar = everywhere (mkT convert)

298296 convert :: JS -> JS

299297 convert (JSApp (JSApp dollar [f]) [x]) | isDollar dollar = JSApp f [x]

300298 convert other = other

301− isDollar (JSAccessor name (JSVar (Ident "Prelude"))) | name == identToJs (Op "$") = True

299+ isDollar (JSAccessor name (JSVar "Prelude")) | name == identToJs (Op "$") = True

302300 isDollar _ = False

src/Language/PureScript/Parser/JS.hs+5−5

@@ -52,8 +52,8 @@ parseIdentifierAndValue = (,) <$> (C.identifier <* C.colon)

5252parseFunction :: P.Parsec String u JS

5353parseFunction = do

5454 C.reserved "function"

55− name <- P.optionMaybe (Ident <$> C.identifier)

56− args <- P.parens C.tokenParser $ P.commaSep C.tokenParser (Ident <$> C.identifier)

55+ name <- P.optionMaybe C.identifier

56+ args <- P.parens C.tokenParser $ P.commaSep C.tokenParser C.identifier

5757 body <- parseJS

5858 return $ JSFunction name args body

5959

@@ -61,7 +61,7 @@ parseBlock :: P.Parsec String u JS

6161parseBlock = JSBlock <$> P.braces C.tokenParser (P.many parseJS)

6262

6363parseVar :: P.Parsec String u JS

64−parseVar = JSVar <$> Ident <$> C.identifier

64+parseVar = JSVar <$> C.identifier

6565

6666parseJSAtom :: P.Parsec String u JS

6767parseJSAtom = P.choice

@@ -141,7 +141,7 @@ parseJS =

141141parseVariableIntroduction :: P.Parsec String u JS

142142parseVariableIntroduction = do

143143 C.reserved "var"

144− name <- Ident <$> P.identifier C.tokenParser

144+ name <- P.identifier C.tokenParser

145145 value <- P.optionMaybe $ do

146146 _ <- C.lexeme $ P.char '='

147147 value <- parseJS

@@ -158,7 +158,7 @@ parseAssignment = do

158158 return $ JSAssignment tgt value

159159

160160parseAssignmentTarget :: P.Parsec String u JSAssignment

161−parseAssignmentTarget = C.buildPostfixParser [] (JSAssignVariable <$> Ident <$> P.identifier C.tokenParser)

161+parseAssignmentTarget = C.buildPostfixParser [] (JSAssignVariable <$> P.identifier C.tokenParser)

162162

163163parseWhile :: P.Parsec String u JS

164164parseWhile = JSWhile <$> (C.reserved "while" *> P.parens C.tokenParser parseJS)

src/Language/PureScript/Pretty/Common.hs−48

@@ -13,56 +13,8 @@

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}

17−

1816module Language.PureScript.Pretty.Common where

1917

20−import Data.Char

21−import Control.Monad.State

22−import qualified Control.Category as C

23−import Control.Category ((>>>))

24−import qualified Control.Arrow as A

25−import Control.Arrow ((***), (<+>))

26−

27−import Language.PureScript.Names

28−

29−-- |

30−-- Convert an Ident into a valid Javascript identifier:

31−--

32−-- * Alphanumeric characters are kept unmodified

33−--

34−-- * Symbols are encoded as a dollar symbol ($) followed by their ordinal value

35−--

36−identToJs :: Ident -> String

37−identToJs (Ident name) = concatMap identCharToString name

38−identToJs (Op op) = concatMap identCharToString op

39−identToJs (Escaped name) = name

40−

41−identCharToString :: Char -> String

42−identCharToString c | isAlphaNum c = [c]

43−identCharToString '_' = "_"

44−identCharToString '.' = "$dot"

45−identCharToString '$' = "$dollar"

46−identCharToString '~' = "$tilde"

47−identCharToString '=' = "$eq"

48−identCharToString '<' = "$less"

49−identCharToString '>' = "$greater"

50−identCharToString '!' = "$bang"

51−identCharToString '#' = "$hash"

52−identCharToString '%' = "$percent"

53−identCharToString '^' = "$up"

54−identCharToString '&' = "$amp"

55−identCharToString '|' = "$bar"

56−identCharToString '*' = "$times"

57−identCharToString '/' = "$div"

58−identCharToString '+' = "$plus"

59−identCharToString '-' = "$minus"

60−identCharToString ':' = "$colon"

61−identCharToString '\\' = "$bslash"

62−identCharToString '?' = "$qmark"

63−identCharToString '@' = "$at"

64−identCharToString c = '$' : show (ord c)

65−

6618-- |

6719-- Wrap a string in parentheses

6820--

src/Language/PureScript/Pretty/JS.hs+9−9

@@ -89,10 +89,10 @@ literals = mkPattern' match

8989 , currentIndent

9090 , return "}"

9191 ]

92− match (JSVar ident) = return (identToJs ident)

92+ match (JSVar ident) = return ident

9393 match (JSVariableIntroduction ident value) = fmap concat $ sequence

9494 [ return "var "

95− , return $ identToJs ident

95+ , return ident

9696 , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

9797 ]

9898 match (JSAssignment target value) = fmap concat $ sequence

@@ -107,11 +107,11 @@ literals = mkPattern' match

107107 , prettyPrintJS' sts

108108 ]

109109 match (JSFor ident start end sts) = fmap concat $ sequence

110− [ return $ "for (" ++ identToJs ident ++ " = "

110+ [ return $ "for (" ++ ident ++ " = "

111111 , prettyPrintJS' start

112− , return $ "; " ++ identToJs ident ++ " < "

112+ , return $ "; " ++ ident ++ " < "

113113 , prettyPrintJS' end

114− , return $ "; " ++ identToJs ident ++ "++) "

114+ , return $ "; " ++ ident ++ "++) "

115115 , prettyPrintJS' sts

116116 ]

117117 match (JSIfElse cond thens elses) = fmap concat $ sequence

@@ -139,7 +139,7 @@ literals = mkPattern' match

139139 match _ = mzero

140140

141141targetToJs :: JSAssignment -> String

142−targetToJs (JSAssignVariable ident) = identToJs ident

142+targetToJs (JSAssignVariable ident) = ident

143143targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop

144144

145145conditional :: Pattern PrinterState JS ((JS, JS), JS)

@@ -160,7 +160,7 @@ indexer = mkPattern' match

160160 match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

161161 match _ = mzero

162162

163−lam :: Pattern PrinterState JS ((Maybe Ident, [Ident]), JS)

163+lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)

164164lam = mkPattern match

165165 where

166166 match (JSFunction name args ret) = Just ((name, args), ret)

@@ -227,8 +227,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

227227 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

228228 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

229229 , [ Wrap lam $ \(name, args) ret -> "function "

230− ++ maybe "" identToJs name

231− ++ "(" ++ intercalate ", " (map identToJs args) ++ ") "

230+ ++ maybe "" id name

231+ ++ "(" ++ (intercalate ", " args) ++ ") "

232232 ++ ret ]

233233 , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

234234 , [ binary LessThan "<" ]

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

@@ -44,11 +44,11 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB

4444 namesB (VarBinder name) = [name]

4545 namesB _ = []

4646 namesJS :: JS -> [Ident]

47− namesJS (JSVar name) = [name]

48− namesJS (JSFunction (Just name) args _) = name : args

49− namesJS (JSFunction Nothing args _) = args

50− namesJS (JSVariableIntroduction name _) = [name]

51− namesJS (JSFor name _ _ _) = [name]

47+ namesJS (JSVar name) = [Ident name]

48+ namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)

49+ namesJS (JSFunction Nothing args _) = (Ident `map` args)

50+ namesJS (JSVariableIntroduction name _) = [Ident name]

51+ namesJS (JSFor name _ _ _) = [Ident name]

5252 namesJS _ = []

5353

5454-- |

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

@@ -34,7 +34,7 @@ import Control.Monad.State

3434import Data.Maybe (fromMaybe)

3535import Data.List (nub)

3636import Data.Generics (mkQ, everything)

37−import Language.PureScript.Pretty.Common (identToJs)

37+import Language.PureScript.CodeGen.Common (identToJs)

3838

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

4040

@@ -73,7 +73,7 @@ typeClassDictionaryDeclaration name arg members =

7373typeClassMemberToDictionaryAccessor :: ProperName -> String -> Declaration -> Declaration

7474typeClassMemberToDictionaryAccessor name arg (TypeDeclaration ident ty) =

7575 ExternDeclaration TypeClassAccessorImport ident

76− (Just (JSFunction (Just ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar (Ident "dict")))])))

76+ (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

7777 (ForAll arg (ConstrainedType [(Qualified Nothing name, TypeVar arg)] ty))

7878typeClassMemberToDictionaryAccessor _ _ _ = error "Invalid declaration in type class definition"

7979