0b890e7 · rowtype-yoga/purescript-native

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

Merge branch 'master' into superclasses

Conflicts: src/Language/PureScript/Sugar/TypeClasses.hs

commit0b890e7016a1cababb2a390a2d96abf6b554d796 authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 16:52 (13 years ago) parentbef7806 8dc208f

11 files changed+58−45

compare with golang

unifiedsplit

RELEASE-0.5.md+1 examples/passing/Objects.purs+12 purescript.cabal+1−1 src/Language/PureScript/CodeGen/Common.hs+7−1 src/Language/PureScript/CodeGen/JS.hs+11−7 src/Language/PureScript/CodeGen/JS/AST.hs−2 src/Language/PureScript/Names.hs+1−18 src/Language/PureScript/Parser/Declarations.hs+4−4 src/Language/PureScript/Parser/Types.hs+1−1 src/Language/PureScript/Pretty/JS.hs+6−1 src/Language/PureScript/Sugar/TypeClasses.hs+14−10

RELEASE-0.5.md+1

@@ -52,6 +52,7 @@

5252- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)

5353- Error messages now display source positions (paf31, garyb)

5454- The type classes implementation and code generation was greatly simplified. (paf31)

55+- Object properties and row labels can now be accessed with arbitrary string names by using string literals. (paf31)

5556

5657### Bug Fixes

5758

examples/passing/Objects.purs+12

@@ -14,5 +14,17 @@ module Main where

1414

1515 typed :: { foo :: Number }

1616 typed = { foo: 0 }

17+

18+ test2 = \x -> x."!@#"

19+

20+ test3 = typed."foo"

21+

22+ test4 = test2 weirdObj

23+ where

24+ weirdObj :: { "!@#" :: Number }

25+ weirdObj = { "!@#": 1 }

26+

27+ test5 = case { "***": 1 } of

28+ { "***" = n } -> n

1729

1830 main = Debug.Trace.trace "Done"

purescript.cabal+1−1

@@ -1,5 +1,5 @@

11name: purescript

2−version: 0.4.15.1

2+version: 0.4.16

33cabal-version: >=1.8

44build-type: Custom

55license: MIT

src/Language/PureScript/CodeGen/Common.hs+7−1

@@ -32,7 +32,6 @@ identToJs :: Ident -> String

3232identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

3333identToJs (Ident name) = concatMap identCharToString name

3434identToJs (Op op) = concatMap identCharToString op

35−identToJs (Escaped name) = name

3635

3736-- |

3837-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

@@ -130,5 +129,12 @@ nameIsJsReserved name =

130129 , "with"

131130 , "yield" ]

132131

132+-- |

133+-- Test if a string is a valid JS identifier (may return false negatives)

134+--

135+isIdent :: String -> Bool

136+isIdent s@(first : rest) | not (nameIsJsReserved s) && isAlpha first && all isAlphaNum rest = True

137+isIdent _ = False

138+

133139moduleNameToJs :: ModuleName -> String

134140moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

src/Language/PureScript/CodeGen/JS.hs+11−7

@@ -19,7 +19,8 @@ module Language.PureScript.CodeGen.JS (

1919 module AST,

2020 declToJs,

2121 moduleToJs,

22− wrapExportsContainer

22+ wrapExportsContainer,

23+ isIdent

2324) where

2425

2526import Data.Maybe (fromMaybe, mapMaybe)

@@ -90,7 +91,7 @@ declToJs _ _ _ _ = Nothing

9091-- module.

9192--

9293exportToJs :: DeclarationRef -> [JS]

93−exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Escaped . runProperName)

94+exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)

9495exportToJs (ValueRef name) = [export name]

9596exportToJs (TypeInstanceRef name) = [export name]

9697exportToJs _ = []

@@ -115,9 +116,12 @@ var = JSVar . identToJs

115116-- indexer is returned.

116117--

117118accessor :: Ident -> JS -> JS

118−accessor (Ident name) | nameIsJsReserved name = JSIndexer (JSStringLiteral name)

119+accessor (Ident prop) = accessorString prop

119120accessor (Op op) = JSIndexer (JSStringLiteral op)

120−accessor ident = JSAccessor (identToJs ident)

121+

122+accessorString :: String -> JS -> JS

123+accessorString prop | isIdent prop = JSAccessor prop

124+ | otherwise = JSIndexer (JSStringLiteral prop)

121125

122126-- |

123127-- Generate code in the simplified Javascript intermediate representation for a value or expression.

@@ -132,7 +136,7 @@ valueToJs opts m e (ObjectUpdate o ps) = extendObj (valueToJs opts m e o) (map (

132136valueToJs _ m _ (Constructor name) = qualifiedToJS m (Ident . runProperName) name

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

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

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

139+valueToJs opts m e (Accessor prop val) = accessorString prop (valueToJs opts m e val)

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

137141valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []

138142valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])

@@ -199,7 +203,7 @@ runtimeTypeChecks arg ty =

199203 let

200204 (pairs, _) = rowToList row

201205 in

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

206+ typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs

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

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

205209 argumentCheck _ _ = []

@@ -284,7 +288,7 @@ binderToJs m e varName done (ObjectBinder bs) = go done bs

284288 propVar <- fresh

285289 done'' <- go done' bs'

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

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

291+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

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

289293 js <- go done 0 bs

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

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

@@ -19,8 +19,6 @@ module Language.PureScript.CodeGen.JS.AST where

1919

2020import Data.Data

2121

22−

23−

2422-- |

2523-- Built-in unary operators

2624--

src/Language/PureScript/Names.hs+1−18

@@ -19,7 +19,6 @@ module Language.PureScript.Names where

1919

2020import Data.List

2121import Data.Data

22−import Data.Function (on)

2322

2423-- |

2524-- Names for value identifiers

@@ -32,27 +31,11 @@ data Ident

3231 -- |

3332 -- A symbolic name for an infix operator

3433 --

35− | Op String

36− -- |

37− -- An escaped name

38− --

39− | Escaped String deriving (Data, Typeable)

34+ | Op String deriving (Eq, Ord, Data, Typeable)

4035

4136instance Show Ident where

4237 show (Ident s) = s

4338 show (Op op) = '(':op ++ ")"

44− show (Escaped s) = s

45−

46−instance Eq Ident where

47− Ident s1 == Ident s2 = s1 == s2

48− Op s1 == Op s2 = s1 == s2

49− Escaped s1 == Escaped s2 = s1 == s2

50− Ident s1 == Escaped s2 = s1 == s2

51− Escaped s1 == Ident s2 = s1 == s2

52− _ == _ = False

53−

54−instance Ord Ident where

55− compare = compare `on` show

5639

5740-- |

5841-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

src/Language/PureScript/Parser/Declarations.hs+4−4

@@ -232,7 +232,7 @@ parseObjectLiteral :: P.Parsec String ParseState Value

232232parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

233233

234234parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

235−parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)

235+parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)

236236 <*> (C.indented *> parseValue)

237237

238238parseAbs :: P.Parsec String ParseState Value

@@ -295,14 +295,14 @@ parseValueAtom = P.choice

295295

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

297297parsePropertyUpdate = do

298− name <- C.lexeme C.identifier

298+ name <- C.lexeme (C.identifier <|> C.stringLiteral)

299299 _ <- C.lexeme $ C.indented *> P.char '='

300300 value <- C.indented *> parseValue

301301 return (name, value)

302302

303303parseAccessor :: Value -> P.Parsec String ParseState Value

304304parseAccessor (Constructor _) = P.unexpected "constructor"

305−parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj

305+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj

306306

307307parseDo :: P.Parsec String ParseState Value

308308parseDo = do

@@ -377,7 +377,7 @@ parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> retu

377377

378378parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)

379379parseIdentifierAndBinder = do

380− name <- C.lexeme C.identifier

380+ name <- C.lexeme (C.identifier <|> C.stringLiteral)

381381 _ <- C.lexeme $ C.indented *> P.char '='

382382 binder <- C.indented *> parseBinder

383383 return (name, binder)

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

@@ -118,7 +118,7 @@ parsePolyType :: P.Parsec String ParseState Type

118118parsePolyType = parseAnyType

119119

120120parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

121−parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p

121+parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* indented <* lexeme (P.string "::")) <*> p

122122

123123parseRowEnding :: P.Parsec String ParseState Type

124124parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

src/Language/PureScript/Pretty/JS.hs+6−1

@@ -18,6 +18,7 @@ module Language.PureScript.Pretty.JS (

1818) where

1919

2020import Language.PureScript.Pretty.Common

21+import Language.PureScript.CodeGen.JS (isIdent)

2122import Language.PureScript.CodeGen.JS.AST

2223

2324import Data.List

@@ -46,13 +47,17 @@ literals = mkPattern' match

4647 match (JSObjectLiteral ps) = fmap concat $ sequence

4748 [ return "{\n"

4849 , withIndent $ do

49− jss <- forM ps $ \(key, value) -> fmap ((key ++ ": ") ++) . prettyPrintJS' $ value

50+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value

5051 indentString <- currentIndent

5152 return $ intercalate ", \n" $ map (indentString ++) jss

5253 , return "\n"

5354 , currentIndent

5455 , return "}"

5556 ]

57+ where

58+ objectPropertyToString :: String -> String

59+ objectPropertyToString s | isIdent s = s

60+ | otherwise = show s

5661 match (JSBlock sts) = fmap concat $ sequence

5762 [ return "{\n"

5863 , withIndent $ prettyStatements sts

src/Language/PureScript/Sugar/TypeClasses.hs+14−10

@@ -29,7 +29,7 @@ import Language.PureScript.CodeGen.Common (identToJs)

2929

3030import Control.Applicative

3131import Control.Monad.State

32−import Control.Arrow (second)

32+import Control.Arrow (first, second)

3333import Data.Maybe (catMaybes)

3434

3535import qualified Data.Map as M

@@ -97,19 +97,23 @@ desugarDecl mn (PositionedDeclaration pos d) = do

9797 return (dr, map (PositionedDeclaration pos) ds)

9898desugarDecl _ other = return (Nothing, [other])

9999

100−memberToNameAndType :: Declaration -> (String, Type)

101−memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

100+memberToNameAndType :: Declaration -> (Ident, Type)

101+memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

102102memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

103103memberToNameAndType _ = error "Invalid declaration in type class definition"

104104

105+identToProperty :: Ident -> String

106+identToProperty (Ident name) = name

107+identToProperty (Op op) = op

108+

105109typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

106110typeClassDictionaryDeclaration name args members =

107− TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty))

111+ TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map (first identToProperty . memberToNameAndType) members, REmpty))

108112

109113typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration

110114typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

111115 ExternDeclaration TypeClassAccessorImport ident

112− (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

116+ (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSIndexer (JSStringLiteral (identToProperty ident)) (JSVar "dict"))])))

113117 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

114118typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

115119 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

@@ -127,13 +131,13 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

127131 -- Replace the type arguments with the appropriate types in the member types

128132 let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

129133 -- Create values for the type instance members

130− memberNames <- mapM (memberToNameAndValue memberTypes) decls

134+ memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls

131135 -- Create the type of the dictionary

132136 -- The type is an object type, but depending on type instance dependencies, may be constrained.

133137 -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary

134138 -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no

135139 -- dependencies, we introduce an unnamed function parameter.

136− let dictTy = TypeApp tyObject (rowFromList (memberTypes, REmpty))

140+ let dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, REmpty))

137141 constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)

138142 dict = if null deps then Abs (Left (Ident "_")) (ObjectLiteral memberNames) else ObjectLiteral memberNames

139143 return $ ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)

@@ -141,11 +145,11 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

141145 unit :: Type

142146 unit = TypeApp tyObject REmpty

143147

144− memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

148+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

145149 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

146− _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup (identToJs ident) tys'

150+ _ <- lift . maybe (Left $ mkErrorStack "Type class member type not found" Nothing) Right $ lookup ident tys'

147151 let memberValue = typeInstanceDictionaryEntryValue d

148− return (identToJs ident, memberValue)

152+ return (ident, memberValue)

149153 memberToNameAndValue tys' (PositionedDeclaration pos d) = do

150154 (ident, val) <- memberToNameAndValue tys' d

151155 return (ident, PositionedValue pos val)