3d38716 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #476 from purescript/prototypes-with-typeclasses

3d38716Gary Burgess12 years ago

examples/passing/Comparisons.pursnew file+23

compare with golang

unifiedsplit

@@ -0,0 +1,23 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+foreign import data Assert :: !

8+foreign import assert

9+ "function assert(x) {\

10+ \ return function () {\

11+ \ if (!x) throw new Error('assertion failed');\

12+ \ return {};\

13+ \ };\

14+ \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit

15+

16+main = do

17+ assert (1 < 2)

18+ assert (2 == 2)

19+ assert (3 > 1)

20+ assert ("a" < "b")

21+ assert ("a" == "a")

22+ assert ("z" > "a")

23+ trace "Done!"

examples/passing/TypeClassMemberOrderChange.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+class Test a where

4+ fn :: a -> a -> a

5+ val :: a

7+instance testBoolean :: Test Boolean where

8+ val = true

9+ fn x y = y

10+

11+main = Debug.Trace.trace (show (fn true val))

prelude/prelude.purs+1−1

@@ -335,7 +335,7 @@ module Prelude

335 foreign import unsafeCompare

336 "function unsafeCompare(n1) {\

337 \ return function(n2) {\

338− \ return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\

338+ \ return n1 < n2 ? LT.value : n1 > n2 ? GT.value : EQ.value;\

339 \ };\

340 \}" :: forall a. a -> a -> Ordering

341

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

@@ -33,6 +33,12 @@ identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

33identToJs (Ident name) = concatMap identCharToString name

34identToJs (Op op) = concatMap identCharToString op

36+-- |

37+-- Test if a string is a valid JS identifier without escaping.

38+--

39+identNeedsEscaping :: String -> Bool

40+identNeedsEscaping s = s /= identToJs (Ident s)

41+

36-- |

42-- |

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

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

38-- ordinal value.

44-- ordinal value.

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

130 , "with"

136 , "with"

131 , "yield" ]

137 , "yield" ]

132

138

133−-- |

134−-- Test if a string is a valid JS identifier (may return false negatives)

135−--

136−isIdent :: String -> Bool

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

138−isIdent _ = False

139−

140moduleNameToJs :: ModuleName -> String

139moduleNameToJs :: ModuleName -> String

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

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

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

@@ -20,12 +20,12 @@ module Language.PureScript.CodeGen.JS (

20 ModuleType(..),

21 declToJs,

22 moduleToJs,

23− isIdent

23+ identNeedsEscaping

24) where

26import Data.Maybe (catMaybes, fromJust, fromMaybe)

27import Data.Function (on)

28−import Data.List (nub, (\\), delete)

28+import Data.List (nub, (\\), delete, sortBy)

30import Control.Monad (replicateM, forM)

31import Control.Applicative

@@ -42,7 +42,6 @@ import Language.PureScript.CodeGen.Common

42import Language.PureScript.Environment

43import Language.PureScript.Supply

44import Language.PureScript.Traversals (sndM)

45−

46import qualified Language.PureScript.Constants as C

45import qualified Language.PureScript.Constants as C

48-- |

47-- |

@@ -81,14 +80,19 @@ importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleB

81 Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))

80 Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))

83imports :: Declaration -> [ModuleName]

82imports :: Declaration -> [ModuleName]

84−imports =

83+imports (ImportDeclaration mn _ _) = [mn]

84+imports other =

85− let (f, _, _, _, _) = everythingOnValues (++) (const []) collect (const []) (const []) (const [])

85+ let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])

86− in f

86+ in f other

87 where

88− collect :: Value -> [ModuleName]

88+ collectV :: Value -> [ModuleName]

89− collect (Var (Qualified (Just mn) _)) = [mn]

89+ collectV (Var (Qualified (Just mn) _)) = [mn]

90− collect (Constructor (Qualified (Just mn) _)) = [mn]

90+ collectV (Constructor (Qualified (Just mn) _)) = [mn]

91− collect _ = []

91+ collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]

92+ collectV _ = []

93+ collectB :: Binder -> [ModuleName]

94+ collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]

95+ collectB _ = []

93-- |

97-- |

94-- Generate code in the simplified Javascript intermediate representation for a declaration

98-- Generate code in the simplified Javascript intermediate representation for a declaration

@@ -102,19 +106,48 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do

102 js <- valueToJs opts mp e val

106 js <- valueToJs opts mp e val

103 return $ JSVariableIntroduction (identToJs ident) (Just js)

107 return $ JSVariableIntroduction (identToJs ident) (Just js)

104 return $ Just jss

108 return $ Just jss

105−declToJs _ mp (DataDeclaration _ _ ctors) _ = do

109+declToJs _ mp (DataDeclaration _ _ ctors) e = do

106 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

110 return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

107− [JSVariableIntroduction ctor (Just (go pn 0 tys []))]

111+ let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"

112+ in [ makeConstructor ctor (length tys)

113+ , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])

114+ ]

108 where

115 where

109− go :: ProperName -> Integer -> [Type] -> [JS] -> JS

116+ makeConstructor :: String -> Int -> JS

110− go pn _ [] values =

117+ makeConstructor ctorName n =

111− JSObjectLiteral [ ("ctor", JSStringLiteral (show (Qualified (Just mp) pn))), ("values", JSArrayLiteral $ reverse values) ]

118+ let

119+ args = [ "value" ++ show index | index <- [0..n-1] ]

120+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]

121+ in JSFunction (Just ctorName) args (JSBlock body)

122+ go :: ProperName -> Int -> Int -> [JS] -> JS

123+ go pn _ 0 values = JSApp (JSNew (JSVar (runProperName pn))) (reverse values)

112− go pn index (_ : tys') values =

124+ go pn index n values =

113 JSFunction Nothing ["value" ++ show index]

125 JSFunction Nothing ["value" ++ show index]

114− (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

126+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])

115declToJs opts mp (DataBindingGroupDeclaration ds) e = do

127declToJs opts mp (DataBindingGroupDeclaration ds) e = do

116 jss <- mapM (\decl -> declToJs opts mp decl e) ds

128 jss <- mapM (\decl -> declToJs opts mp decl e) ds

117 return $ Just $ concat $ catMaybes jss

129 return $ Just $ concat $ catMaybes jss

130+declToJs _ _ (TypeClassDeclaration name _ supers members) _ =

131+ return $ Just $ [

132+ JSFunction (Just $ runProperName name) (identToJs `map` args)

133+ (JSBlock $ assn `map` args)]

134+ where

135+ assn :: Ident -> JS

136+ assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)

137+ args :: [Ident]

138+ args = sortBy (compare `on` runIdent) $ memberNames ++ superNames

139+ memberNames :: [Ident]

140+ memberNames = memberToName `map` members

141+ superNames :: [Ident]

142+ superNames = [ toSuperName superclass index

143+ | (index, (superclass, _)) <- zip [0..] supers

144+ ]

145+ toSuperName :: Qualified ProperName -> Integer -> Ident

146+ toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index

147+ memberToName :: Declaration -> Ident

148+ memberToName (TypeDeclaration ident _) = ident

149+ memberToName (PositionedDeclaration _ d) = memberToName d

150+ memberToName _ = error "Invalid declaration in type class definition"

118declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]

151declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]

119declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

152declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

120declToJs _ _ _ _ = return Nothing

153declToJs _ _ _ _ = return Nothing

@@ -126,6 +159,7 @@ exportToJs :: DeclarationRef -> [(String, JS)]

126exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors

159exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors

127exportToJs (ValueRef name) = [(runIdent name, var name)]

160exportToJs (ValueRef name) = [(runIdent name, var name)]

128exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]

161exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]

162+exportToJs (TypeClassRef name) = [(runProperName name, var $ Ident $ runProperName name)]

129exportToJs _ = []

163exportToJs _ = []

130

164

131-- |

165-- |

@@ -145,8 +179,8 @@ accessor (Ident prop) = accessorString prop

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

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

146

180

147accessorString :: String -> JS -> JS

181accessorString :: String -> JS -> JS

148−accessorString prop | isIdent prop = JSAccessor prop

149− | otherwise = JSIndexer (JSStringLiteral prop)

182+accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

183+ | otherwise = JSAccessor prop

150

184

151-- |

185-- |

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

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

@@ -157,11 +191,17 @@ valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

157valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

191valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

158valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs

192valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs

159valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps

193valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps

194+valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =

195+ JSApp (JSNew (qualifiedToJS m (Ident . runProperName) name)) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)

196+valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =

197+ error "TypeClassDictionaryConstructorApp did not contain object literal"

160valueToJs opts m e (ObjectUpdate o ps) = do

198valueToJs opts m e (ObjectUpdate o ps) = do

161 obj <- valueToJs opts m e o

199 obj <- valueToJs opts m e o

162 sts <- mapM (sndM (valueToJs opts m e)) ps

200 sts <- mapM (sndM (valueToJs opts m e)) ps

163 extendObj obj sts

201 extendObj obj sts

202+valueToJs _ m e (Constructor name) =

203+ let propName = if isNullaryConstructor e name then "value" else "create"

164−valueToJs _ m _ (Constructor name) = return $ qualifiedToJS m (Ident . runProperName) name

204+ in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name

165valueToJs opts m e (Case values binders) = do

205valueToJs opts m e (Case values binders) = do

166 vals <- mapM (valueToJs opts m e) values

206 vals <- mapM (valueToJs opts m e) values

167 bindersToJs opts m e binders vals

207 bindersToJs opts m e binders vals

@@ -297,7 +337,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do

297 then

337 then

298 return js

338 return js

299 else

339 else

300− return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ctor)))

340+ return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))

301 (JSBlock js)

341 (JSBlock js)

302 Nothing]

342 Nothing]

303 where

343 where

@@ -307,7 +347,7 @@ binderToJs m e varName done (ConstructorBinder ctor bs) = do

307 argVar <- freshName

347 argVar <- freshName

308 done'' <- go (index + 1) done' bs'

348 done'' <- go (index + 1) done' bs'

309 js <- binderToJs m e argVar done'' binder

349 js <- binderToJs m e argVar done'' binder

310− return (JSVariableIntroduction argVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSAccessor "values" (JSVar varName)))) : js)

350+ return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)

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

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

312 where

352 where

313 go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

353 go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

@@ -357,3 +397,11 @@ isOnlyConstructor e ctor =

357 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

397 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)

358 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

398 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

359

399

400+isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

401+isNullaryConstructor e ctor =

402+ not . isFunction . snd . fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

403+ where

404+ isFunction :: Type -> Bool

405+ isFunction (ForAll _ t _) = isFunction t

406+ isFunction (TypeApp t _) = isFunction t

407+ isFunction t = t == tyFunction

src/Language/PureScript/CodeGen/JS/AST.hs+14

@@ -170,6 +170,10 @@ data JS

170 --

171 | JSApp JS [JS]

172 -- |

173+ -- Constructor

174+ --

175+ | JSNew JS

176+ -- |

173 -- Variable

177 -- Variable

174 --

178 --

175 | JSVar String

179 | JSVar String

@@ -218,6 +222,10 @@ data JS

218 --

222 --

219 | JSTypeOf JS

223 | JSTypeOf JS

220 -- |

224 -- |

225+ -- InstanceOf test

226+ --

227+ | JSInstanceOf JS JS

228+ -- |

221 -- Labelled statement

229 -- Labelled statement

222 --

230 --

223 | JSLabel String JS

231 | JSLabel String JS

@@ -262,6 +270,8 @@ everywhereOnJS f = go

262 go (JSThrow js) = f (JSThrow (go js))

270 go (JSThrow js) = f (JSThrow (go js))

263 go (JSTypeOf js) = f (JSTypeOf (go js))

271 go (JSTypeOf js) = f (JSTypeOf (go js))

264 go (JSLabel name js) = f (JSLabel name (go js))

272 go (JSLabel name js) = f (JSLabel name (go js))

273+ go (JSNew j) = f (JSNew (go j))

274+ go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))

265 go other = f other

275 go other = f other

266

276

267everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

277everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

@@ -288,6 +298,8 @@ everywhereOnJSTopDown f = go . f

288 go (JSThrow j) = JSThrow (go (f j))

298 go (JSThrow j) = JSThrow (go (f j))

289 go (JSTypeOf j) = JSTypeOf (go (f j))

299 go (JSTypeOf j) = JSTypeOf (go (f j))

290 go (JSLabel name j) = JSLabel name (go (f j))

300 go (JSLabel name j) = JSLabel name (go (f j))

301+ go (JSNew j) = JSNew (go (f j))

302+ go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))

291 go other = f other

303 go other = f other

292

304

293everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

305everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r

@@ -314,4 +326,6 @@ everythingOnJS (<>) f = go

314 go j@(JSThrow j1) = f j <> go j1

326 go j@(JSThrow j1) = f j <> go j1

315 go j@(JSTypeOf j1) = f j <> go j1

327 go j@(JSTypeOf j1) = f j <> go j1

316 go j@(JSLabel _ j1) = f j <> go j1

328 go j@(JSLabel _ j1) = f j <> go j1

329+ go j@(JSNew j1) = f j <> go j1

330+ go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2

317 go other = f other

331 go other = f other

src/Language/PureScript/Constants.hs+2−2

@@ -186,8 +186,8 @@ main = "main"

186

187-- Code Generation

188

189−__superclasses :: String

189+__superclass_ :: String

190−__superclasses = "__superclasses"

190+__superclass_ = "__superclass_"

191

192-- Modules

193

src/Language/PureScript/DeadCodeElimination.hs+2

@@ -80,6 +80,8 @@ dependencies moduleName =

80 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]

81 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

82 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

83+ values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]

84+ values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"

83 values _ = []

85 values _ = []

85isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

87isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

src/Language/PureScript/Declarations.hs+11

@@ -332,6 +332,11 @@ data Value

332 --

333 | Do [DoNotationElement]

334 -- |

335+ -- An application of a typeclass dictionary constructor. The value should be

336+ -- an ObjectLiteral.

337+ --

338+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Value

339+ -- |

335 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

340 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

336 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

341 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

337 -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look

342 -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look

@@ -483,6 +488,7 @@ everywhereOnValues f g h = (f', g', h')

483 g' (Parens v) = g (Parens (g' v))

488 g' (Parens v) = g (Parens (g' v))

484 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

489 g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))

485 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

490 g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))

491+ g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))

486 g' (Accessor prop v) = g (Accessor prop (g' v))

492 g' (Accessor prop v) = g (Accessor prop (g' v))

487 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

493 g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))

488 g' (Abs name v) = g (Abs name (g' v))

494 g' (Abs name v) = g (Abs name (g' v))

@@ -538,6 +544,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

538 g' (Parens v) = Parens <$> (g v >>= g')

544 g' (Parens v) = Parens <$> (g v >>= g')

539 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

545 g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs

540 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

546 g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs

547+ g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')

541 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

548 g' (Accessor prop v) = Accessor prop <$> (g v >>= g')

542 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

549 g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs

543 g' (Abs name v) = Abs name <$> (g v >>= g')

550 g' (Abs name v) = Abs name <$> (g v >>= g')

@@ -587,6 +594,7 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

587 g' (Parens v) = (Parens <$> g' v) >>= g

594 g' (Parens v) = (Parens <$> g' v) >>= g

588 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

595 g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g

589 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

596 g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g

597+ g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g

590 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

598 g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g

591 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

599 g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g

592 g' (Abs name v) = (Abs name <$> g' v) >>= g

600 g' (Abs name v) = (Abs name <$> g' v) >>= g

@@ -639,6 +647,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')

639 g' v@(Parens v1) = g v <> g' v1

647 g' v@(Parens v1) = g v <> g' v1

640 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

648 g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)

641 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

649 g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)

650+ g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1

642 g' v@(Accessor _ v1) = g v <> g' v1

651 g' v@(Accessor _ v1) = g v <> g' v1

643 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

652 g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

644 g' v@(Abs _ v1) = g v <> g' v1

653 g' v@(Abs _ v1) = g v <> g' v1

@@ -702,6 +711,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

702 g' s (Parens v1) = (g'' s) v1

711 g' s (Parens v1) = (g'' s) v1

703 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

712 g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)

704 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

713 g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)

714+ g' s (TypeClassDictionaryConstructorApp _ v1) = (g'' s) v1

705 g' s (Accessor _ v1) = (g'' s) v1

715 g' s (Accessor _ v1) = (g'' s) v1

706 g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)

716 g' s (ObjectUpdate obj vs) = foldl (<>) ((g'' s) obj) (map (g'' s . snd) vs)

707 g' s (Abs _ v1) = (g'' s) v1

717 g' s (Abs _ v1) = (g'' s) v1

@@ -767,6 +777,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

767 g' s (Parens v) = Parens <$> g'' s v

777 g' s (Parens v) = Parens <$> g'' s v

768 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

778 g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs

769 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

779 g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs

780+ g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g'' s) v

770 g' s (Accessor prop v) = Accessor prop <$> g'' s v

781 g' s (Accessor prop v) = Accessor prop <$> g'' s v

771 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

782 g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs

772 g' s (Abs name v) = Abs name <$> g'' s v

783 g' s (Abs name v) = Abs name <$> g'' s v

src/Language/PureScript/Optimizer/Inliner.hs+2−1

@@ -49,6 +49,8 @@ etaConvert = everywhereOnJS convert

49 not (any (`isRebound` block) (map JSVar idents)) &&

50 not (any (`isRebound` block) args)

51 = JSBlock (map (replaceIdents (zip idents args)) body)

52+ convert (JSFunction Nothing ["_"] (JSBlock [JSReturn (JSApp fn@JSVar{} [JSObjectLiteral []])]))

53+ = fn

52 convert js = js

54 convert js = js

54unThunk :: JS -> JS

56unThunk :: JS -> JS

@@ -153,7 +155,6 @@ inlineCommonOperators = applyAll $

153 isOp _ = False

155 isOp _ = False

154 isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName

156 isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName

155 isOpDict _ _ = False

157 isOpDict _ _ = False

156−

157 mkFn :: Int -> JS -> JS

158 mkFn :: Int -> JS -> JS

158 mkFn 0 = everywhereOnJS convert

159 mkFn 0 = everywhereOnJS convert

159 where

160 where

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

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

18) where

20import Language.PureScript.Pretty.Common

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

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

22import Language.PureScript.CodeGen.JS.AST

24import Data.List

@@ -56,8 +56,8 @@ literals = mkPattern' match

56 ]

57 where

58 objectPropertyToString :: String -> String

59− objectPropertyToString s | isIdent s = s

59+ objectPropertyToString s | identNeedsEscaping s = show s

60− | otherwise = show s

60+ | otherwise = s

61 match (JSBlock sts) = fmap concat $ sequence

62 [ return "{\n"

63 , withIndent $ prettyStatements sts

@@ -174,6 +174,18 @@ typeOf = mkPattern match

174 match (JSTypeOf val) = Just ((), val)

175 match _ = Nothing

176

177+instanceOf :: Pattern PrinterState JS (JS, JS)

178+instanceOf = mkPattern match

179+ where

180+ match (JSInstanceOf val ty) = Just (val, ty)

181+ match _ = Nothing

182+

183+new :: Pattern PrinterState JS ((), JS)

184+new = mkPattern match

185+ where

186+ match (JSNew ctor) = Just ((), ctor)

187+ match _ = Nothing

188+

177unary :: UnaryOperator -> String -> Operator PrinterState JS String

189unary :: UnaryOperator -> String -> Operator PrinterState JS String

178unary op str = Wrap match (++)

190unary op str = Wrap match (++)

179 where

191 where

@@ -222,6 +234,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

222 operators =

234 operators =

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

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

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

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

237+ , [ Wrap new $ \_ s -> "new " ++ s ]

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

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

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

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

227 ++ fromMaybe "" name

240 ++ fromMaybe "" name

@@ -232,6 +245,7 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

232 , [ binary GreaterThan ">" ]

245 , [ binary GreaterThan ">" ]

233 , [ binary GreaterThanOrEqualTo ">=" ]

246 , [ binary GreaterThanOrEqualTo ">=" ]

234 , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

247 , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

248+ , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

235 , [ unary Not "!" ]

249 , [ unary Not "!" ]

236 , [ unary BitwiseNot "~" ]

250 , [ unary BitwiseNot "~" ]

237 , [ unary Negate "-" ]

251 , [ unary Negate "-" ]

src/Language/PureScript/Pretty/Values.hs+7−2

@@ -51,6 +51,11 @@ literals = mkPattern' match

51 , currentIndent

52 , return "}"

53 ]

54+ match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence

55+ [ return ((show className) ++ "(\n")

56+ , match ps

57+ , return ")"

58+ ]

54 match (Constructor name) = return $ show name

59 match (Constructor name) = return $ show name

55 match (Case values binders) = fmap concat $ sequence

60 match (Case values binders) = fmap concat $ sequence

56 [ return "case "

61 [ return "case "

@@ -73,8 +78,8 @@ literals = mkPattern' match

73 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

78 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

74 , currentIndent

79 , currentIndent

75 ]

80 ]

76− match (TypeClassDictionary _ _ _) = return "<<dict>>"

81+ match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

77− match (SuperClassDictionary _ _) = return "<<superclass dict>>"

82+ match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

78 match (TypedValue _ val _) = prettyPrintValue' val

83 match (TypedValue _ val _) = prettyPrintValue' val

79 match (PositionedValue _ val) = prettyPrintValue' val

84 match (PositionedValue _ val) = prettyPrintValue' val

80 match _ = mzero

85 match _ = mzero

src/Language/PureScript/Sugar/TypeClasses.hs+71−32

@@ -82,31 +82,73 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

82-- instance subString :: Sub String where

83-- sub = ""

84--

85−-- becomes

85+-- becomes:

86+--

87+-- <TypeClassDeclaration Foo ...>

86--

88--

87-- type Foo a = { foo :: a -> a }

89-- type Foo a = { foo :: a -> a }

88--

90--

89−-- foreign import foo "function foo(dict) {\

91+-- -- this following type is marked as not needing to be checked so a new Abs

90−-- \ return dict.foo;\

92+-- -- is not introduced around the definition in type checking, but when

93+-- -- called the dictionary value is still passed in for the `dict` argument

91−-- \}" :: forall a. (Foo a) => a -> a

94+-- foo :: forall a. (Foo a) => a -> a

95+-- foo dict = dict.foo

92--

96--

93-- fooString :: {} -> Foo String

97-- fooString :: {} -> Foo String

94−-- fooString _ = { foo: \s -> s ++ s }

98+-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>

95--

99--

96-- fooArray :: forall a. (Foo a) => Foo [a]

100-- fooArray :: forall a. (Foo a) => Foo [a]

97−-- fooArray = { foo: map foo }

101+-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>

98--

102--

99-- {- Superclasses -}

103-- {- Superclasses -}

100--

104--

101−-- ...

105+-- <TypeClassDeclaration Sub ...>

106+--

107+-- type Sub a = { sub :: a

108+-- , "__superclass_Foo_0" :: {} -> Foo a

109+-- }

110+--

111+-- -- As with `foo` above, this type is unchecked at the declaration

112+-- sub :: forall a. (Sub a) => a

113+-- sub dict = dict.sub

114+--

115+-- subString :: {} -> Sub String

116+-- subString _ = { sub: "",

117+-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>

118+-- }

119+--

120+-- and finally as the generated javascript:

121+--

122+-- function Foo(foo) {

123+-- this.foo = foo;

124+-- };

125+--

126+-- var foo = function (dict) {

127+-- return dict.foo;

128+-- };

102--

129--

103−-- subString :: {} -> { __superclasses :: { "Foo": {} -> Foo String }, sub :: String }

130+-- var fooString = function (_) {

104−-- subString _ = {

131+-- return new Foo(function (s) {

105−-- __superclasses: {

132+-- return s + s;

106−-- "Foo": \_ -> <dictionary placeholder to be inserted during type checking\>

133+-- });

134+-- };

135+--

136+-- var fooArray = function (__dict_Foo_15) {

137+-- return new Foo(map(foo(__dict_Foo_15)));

138+-- };

139+--

140+-- function Sub(__superclass_Foo_0, sub) {

141+-- this["__superclass_Foo_0"] = __superclass_Foo_0;

142+-- this.sub = sub;

143+-- };

144+--

145+-- var sub = function (dict) {

146+-- return dict.sub;

107−-- }

147+-- };

108−-- sub: ""

148+--

149+-- var subString = function (_) {

150+-- return new Sub(fooString, "");

109−-- }

151+-- };

110-}

152-}

111desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

153desugarDecl :: ModuleName -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

112desugarDecl mn d@(TypeClassDeclaration name args implies members) = do

154desugarDecl mn d@(TypeClassDeclaration name args implies members) = do

@@ -126,19 +168,15 @@ memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

126memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

168memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

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

128

170

129−identToProperty :: Ident -> String

130−identToProperty (Ident name) = name

131−identToProperty (Op op) = op

132−

133typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

171typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

134typeClassDictionaryDeclaration name args implies members =

172typeClassDictionaryDeclaration name args implies members =

135− let superclassesType = TypeApp tyObject (rowFromList ([ (fieldName, function unit tySynApp)

173+ let superclassTypes = [ (fieldName, function unit tySynApp)

136− | (index, (superclass, tyArgs)) <- zip [0..] implies

174+ | (index, (superclass, tyArgs)) <- zip [0..] implies

137− , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs

175+ , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs

138− , let fieldName = mkSuperclassDictionaryName superclass index

176+ , let fieldName = mkSuperclassDictionaryName superclass index

139− ], REmpty))

177+ ]

140− members' = map (first identToProperty . memberToNameAndType) members

178+ members' = map (first runIdent . memberToNameAndType) members

141− mtys = if null implies then members' else (C.__superclasses, superclassesType) : members'

179+ mtys = members' ++ superclassTypes

142 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

180 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

143

181

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

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

@@ -151,7 +189,7 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

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

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

152

190

153mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String

191mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String

154−mkSuperclassDictionaryName pn index = show pn ++ "_" ++ show index

192+mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index

155

193

156unit :: Type

194unit :: Type

157unit = TypeApp tyObject REmpty

195unit = TypeApp tyObject REmpty

@@ -175,25 +213,26 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

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

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

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

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

177 -- Create values for the type instance members

215 -- Create values for the type instance members

178− memberNames <- map (first identToProperty) <$> mapM (memberToNameAndValue memberTypes) decls

216+ memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls

179 -- Create the type of the dictionary

217 -- Create the type of the dictionary

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

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

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

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

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

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

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

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

184− let superclasses = ObjectLiteral

222+ let superclasses =

185 [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))

223 [ (fieldName, Abs (Left (Ident "_")) (SuperClassDictionary superclass tyArgs))

186 | (index, (superclass, suTyArgs)) <- zip [0..] implies

224 | (index, (superclass, suTyArgs)) <- zip [0..] implies

187 , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs

225 , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs

188 , let fieldName = mkSuperclassDictionaryName superclass index

226 , let fieldName = mkSuperclassDictionaryName superclass index

189 ]

227 ]

190

228

191− let memberNames' = if null implies then memberNames else (C.__superclasses, superclasses) : memberNames

229+ let memberNames' = ObjectLiteral (memberNames ++ superclasses)

192 dictTy = foldl TypeApp (TypeConstructor className) tys

230 dictTy = foldl TypeApp (TypeConstructor className) tys

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

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

232+ dict = TypeClassDictionaryConstructorApp className memberNames'

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

233+ dict' = if null deps then Abs (Left (Ident "_")) dict else dict

195−

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

234+ result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)

235+ return result

197

236

198 where

237 where

199

238

src/Language/PureScript/TypeChecker/Types.hs+8−5

@@ -307,7 +307,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

307 filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True

308 filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True

309 filterModule _ = False

310−

310+

311 solve context' (className, tys) trySuperclasses =

312 let

313 dicts = go trySuperclasses className tys

@@ -326,7 +326,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

326 , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)

327 -- Solve any necessary subgoals

328 , args <- solveSubgoals subst (tcdDependencies tcd) ] ++

329−

329+

330 -- Look for implementations via superclasses

331 [ SubclassDictionaryValue suDict superclass index

332 | trySuperclasses'

@@ -340,7 +340,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

340 -- Finally, satisfy the subclass constraint

341 , args' <- maybeToList $ mapM (flip lookup subst) args

342 , suDict <- go True subclassName args' ]

343−

343+

344 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

345 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

346 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

@@ -360,8 +360,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

360 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])

361 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)

362 dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

363− App (Accessor (show superclassName ++ "_" ++ show index)

363+ App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)

364− (Accessor C.__superclasses (dictionaryValueToValue dict)))

364+ (dictionaryValueToValue dict))

365 (ObjectLiteral [])

366 -- Ensure that a substitution is valid

367 verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]

@@ -931,6 +931,9 @@ check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do

931 ensureNoDuplicateProperties ps

932 ps' <- checkProperties ps row False

933 return $ TypedValue True (ObjectLiteral ps') t

934+check' (TypeClassDictionaryConstructorApp name ps) t = do

935+ ps' <- check' ps t

936+ return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t

934check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

937check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do

935 ensureNoDuplicateProperties ps

938 ensureNoDuplicateProperties ps

936 us <- zip (map fst ps) <$> replicateM (length ps) fresh

939 us <- zip (map fst ps) <$> replicateM (length ps) fresh