f6501d0 · rowtype-yoga/purescript-native

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

Use [..] property access for non-JS-safe ids

Doesn't work for typeclasses yet

commitf6501d081978b4c23d3f1d4e62efc71a6f62df61 authorGary Burgess <garyb@users.noreply.github.com> dateMon 3 Feb 2014, 23:00 (13 years ago) parent16f0260

8 files changed+45−38

compare with golang

unifiedsplit

src/Language/PureScript.hs+1−1 src/Language/PureScript/CodeGen/JS.hs+22−22 src/Language/PureScript/CodeGen/JS/AST.hs+2−2 src/Language/PureScript/CodeGen/Optimize.hs+5−6 src/Language/PureScript/Parser/JS.hs+1−1 src/Language/PureScript/Pretty/Common.hs+5−2 src/Language/PureScript/Pretty/JS.hs+8−3 src/Language/PureScript/Sugar/TypeClasses.hs+1−1

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 (Ident "main") (JSVar (Ident "Main"))) []]

6969 | otherwise -> return js

7070 return (prettyPrintJS js', exts, env)

src/Language/PureScript/CodeGen/JS.hs+22−22

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

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

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

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

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

69+ setProperty ident (JSVar ident) mp ]

7070declToJs opts mp (BindingGroupDeclaration vals) e =

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

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

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

73+ setProperty ident (JSVar ident) mp ]

7474 ) vals

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

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

@@ -82,15 +82,15 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

8282 (JSBlock [JSReturn

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

8484 , ("value", JSVar (Ident "value")) ])])

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

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

8686declToJs opts mp (DataBindingGroupDeclaration ds) e =

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

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

8989 Just [ js

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

90+ , setProperty ident (JSVar ident) mp ]

9191declToJs _ _ _ _ = Nothing

9292

93−setProperty :: String -> JS -> ModuleName -> JS

93+setProperty :: Ident -> JS -> ModuleName -> JS

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

9595

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

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

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

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

101101valueToJs 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)]

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

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

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

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

105+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS id (Qualified (Just aliasModule) aliasIdent)

106106 _ -> JSVar . Ident . runProperName $ name

107−valueToJs _ _ _ (Constructor name) = qualifiedToJS runProperName name

107+valueToJs _ _ _ (Constructor name) = qualifiedToJS (Ident . runProperName) name

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

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

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

111−valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)

111+valueToJs opts m e (Accessor prop val) = JSAccessor (Ident prop) (valueToJs opts m e val)

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

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

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

@@ -140,22 +140,22 @@ runtimeTypeChecks arg ty =

140140 let

141141 (pairs, _) = rowToList row

142142 in

143− typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs

143+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor (Ident prop) val) ty') pairs

144144 argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]

145145 argumentCheck val (ForAll _ ty') = argumentCheck val ty'

146146 argumentCheck _ _ = []

147147 typeCheck :: JS -> String -> JS

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

149149 arrayCheck :: JS -> JS

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

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

151151

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

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

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

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

155+ Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS id (Qualified (Just aliasModule) aliasIdent)

156156 _ -> case qual of

157157 Qualified Nothing _ -> JSVar ident

158− _ -> qualifiedToJS identToJs qual

158+ _ -> qualifiedToJS id qual

159159 where

160160 isExtern (Extern ForeignImport) = True

161161 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

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

163163 Nothing -> error "Undefined alias in varToJs"

164164 isExtern _ = False

165165

166−qualifiedToJS :: (a -> String) -> Qualified a -> JS

166+qualifiedToJS :: (a -> Ident) -> Qualified a -> JS

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

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

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

169169

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

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

@@ -199,16 +199,16 @@ binderToJs m e varName done (NullaryBinder ctor) =

199199 then

200200 return done

201201 else

202− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor)))) (JSBlock done) Nothing]

202+ return [JSIfElse (JSBinary EqualTo (JSAccessor (Ident "ctor") (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor)))) (JSBlock done) Nothing]

203203binderToJs m e varName done (UnaryBinder ctor b) = do

204204 value <- fresh

205205 js <- binderToJs m e value done b

206− let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)

206+ let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor (Ident "value") (JSVar varName))) : js)

207207 if isOnlyConstructor m e ctor

208208 then

209209 return [success]

210210 else

211− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

211+ return [JSIfElse (JSBinary EqualTo (JSAccessor (Ident "ctor") (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ canonicalizeDataConstructor m e ctor))))

212212 success

213213 Nothing]

214214binderToJs m e varName done (ObjectBinder bs) = go done bs

@@ -219,10 +219,10 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs

219219 propVar <- fresh

220220 done'' <- go done' bs'

221221 js <- binderToJs m e propVar done'' binder

222− return (JSVariableIntroduction propVar (Just (JSAccessor prop (JSVar varName))) : js)

222+ return (JSVariableIntroduction propVar (Just (JSAccessor (Ident prop) (JSVar varName))) : js)

223223binderToJs m e varName done (ArrayBinder bs) = do

224224 js <- go done 0 bs

225− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

225+ return [JSIfElse (JSBinary EqualTo (JSAccessor (Ident "length") (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

226226 where

227227 go :: [JS] -> Integer -> [Binder] -> Gen [JS]

228228 go done' _ [] = return done'

@@ -236,9 +236,9 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

236236 tailVar <- fresh

237237 js1 <- binderToJs m e headVar done headBinder

238238 js2 <- binderToJs m e tailVar js1 tailBinder

239− return [JSIfElse (JSBinary GreaterThan (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

239+ return [JSIfElse (JSBinary GreaterThan (JSAccessor (Ident "length") (JSVar varName)) (JSNumericLiteral (Left 0))) (JSBlock

240240 ( JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left 0)) (JSVar varName))) :

241− JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left 1)])) :

241+ JSVariableIntroduction tailVar (Just (JSApp (JSAccessor (Ident "slice") (JSVar varName)) [JSNumericLiteral (Left 1)])) :

242242 js2

243243 )) Nothing]

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

src/Language/PureScript/CodeGen/JS/AST.hs+2−2

@@ -61,7 +61,7 @@ data JS

6161 -- |

6262 -- An object property accessor expression

6363 --

64− | JSAccessor String JS

64+ | JSAccessor Ident JS

6565 -- |

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

6767 --

@@ -142,4 +142,4 @@ data JSAssignment

142142 -- |

143143 -- Assign an object property

144144 --

145− | JSAssignProperty String JSAssignment deriving (Show, Eq, Data, Typeable)

145+ | JSAssignProperty Ident JSAssignment deriving (Show, Eq, Data, Typeable)

src/Language/PureScript/CodeGen/Optimize.hs+5−6

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

4242import Language.PureScript.Names

4343import Language.PureScript.CodeGen.JS.AST

4444import Language.PureScript.Options

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

4645import Language.PureScript.Sugar.TypeClasses

4746 (mkDictionaryValueName)

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

@@ -264,18 +263,18 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)

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

265264 isReturn _ = False

266265 isBindPoly (JSVar (Op ">>=")) = True

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

266+ isBindPoly (JSAccessor prop (JSVar (Ident "Prelude"))) | prop == (Op ">>=") = True

268267 isBindPoly _ = False

269268 isRetPoly (JSVar (Ident "ret")) = True

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

269+ isRetPoly (JSAccessor (Ident "ret") (JSVar (Ident "Prelude"))) = True

271270 isRetPoly _ = False

272271 prelude = ModuleName (ProperName "Prelude")

273272 effModule = ModuleName (ProperName "Eff")

274− Right (Ident effDictName) = mkDictionaryValueName

273+ Right effDictName@(Ident _) = mkDictionaryValueName

275274 effModule

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

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

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

277+ isEffDict (JSVar ident@(Ident _)) | ident == effDictName = True

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

280279 isEffDict _ = False

281280 undo :: JS -> JS

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

298297 convert :: JS -> JS

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

300299 convert other = other

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

300+ isDollar (JSAccessor name (JSVar (Ident "Prelude"))) | name == (Op "$") = True

302301 isDollar _ = False

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

@@ -81,7 +81,7 @@ parseJSAtom = P.choice

8181 , P.parens C.tokenParser parseJS ]

8282

8383parseAccessor :: JS -> P.Parsec String u JS

84−parseAccessor js = P.try $ flip JSAccessor js <$> (C.dot *> P.notFollowedBy C.opLetter *> C.identifier)

84+parseAccessor js = P.try $ flip JSAccessor js <$> (C.dot *> P.notFollowedBy C.opLetter *> (Ident <$> C.identifier))

8585

8686parseIndexer :: JS -> P.Parsec String u JS

8787parseIndexer js = P.try $ flip JSIndexer js <$> (P.squares C.tokenParser parseJS)

src/Language/PureScript/Pretty/Common.hs+5−2

@@ -34,10 +34,13 @@ import Language.PureScript.Names

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

3535--

3636identToJs :: Ident -> String

37−identToJs (Ident name) = concatMap identCharToString name

38−identToJs (Op op) = concatMap identCharToString op

37+identToJs (Ident name) = stringToJsIdent name

38+identToJs (Op op) = stringToJsIdent op

3939identToJs (Escaped name) = name

4040

41+stringToJsIdent :: String -> String

42+stringToJsIdent name = concatMap identCharToString name

43+

4144identCharToString :: Char -> String

4245identCharToString c | isAlphaNum c = [c]

4346identCharToString '_' = "_"

src/Language/PureScript/Pretty/JS.hs+8−3

@@ -140,7 +140,12 @@ literals = mkPattern' match

140140

141141targetToJs :: JSAssignment -> String

142142targetToJs (JSAssignVariable ident) = identToJs ident

143−targetToJs (JSAssignProperty prop target) = targetToJs target ++ "." ++ prop

143+targetToJs (JSAssignProperty prop target) = targetToJs target ++ (propAccess prop)

144+

145+propAccess :: Ident -> String

146+propAccess prop@(Ident id) | (identToJs prop) /= id = "[\"" ++ id ++ "\"]"

147+propAccess (Op op) = "[\"" ++ op ++ "\"]"

148+propAccess prop = "." ++ (identToJs prop)

144149

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

146151conditional = mkPattern match

@@ -148,7 +153,7 @@ conditional = mkPattern match

148153 match (JSConditional cond th el) = Just ((th, el), cond)

149154 match _ = Nothing

150155

151−accessor :: Pattern PrinterState JS (String, JS)

156+accessor :: Pattern PrinterState JS (Ident, JS)

152157accessor = mkPattern match

153158 where

154159 match (JSAccessor prop val) = Just (prop, val)

@@ -223,7 +228,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

223228 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

224229 operators :: OperatorTable PrinterState JS String

225230 operators =

226− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

231+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ (propAccess prop) ]

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

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

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

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

@@ -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 ident) [Ident "dict"] (JSBlock [JSReturn (JSAccessor ident (JSVar (Ident "dict")))])))

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

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

7979