3d38716 · rowtype-yoga/purescript-native

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

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

Prototypes for data constructors and typeclasses

commit3d387168eb0536aaea66d31d96321245969e1320 authorGary Burgess <gary.burgess@gmail.com> dateFri 18 Jul 2014, 22:41 (12 years ago) parentc64d07f 596eb0b

14 files changed+245−75

compare with golang

unifiedsplit

examples/passing/Comparisons.pursnew file+23

@@ -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

335335 foreign import unsafeCompare

336336 "function unsafeCompare(n1) {\

337337 \ return function(n2) {\

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

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

339339 \ };\

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

341341

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

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

3333identToJs (Ident name) = concatMap identCharToString name

3434identToJs (Op op) = concatMap identCharToString op

3535

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+

3642-- |

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

3844-- ordinal value.

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

130136 , "with"

131137 , "yield" ]

132138

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−

140139moduleNameToJs :: ModuleName -> String

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

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

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

2020 ModuleType(..),

2121 declToJs,

2222 moduleToJs,

23− isIdent

23+ identNeedsEscaping

2424) where

2525

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

2727import Data.Function (on)

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

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

2929

3030import Control.Monad (replicateM, forM)

3131import Control.Applicative

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

4242import Language.PureScript.Environment

4343import Language.PureScript.Supply

4444import Language.PureScript.Traversals (sndM)

45−

4645import qualified Language.PureScript.Constants as C

4746

4847-- |

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

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

8281

8382imports :: Declaration -> [ModuleName]

84−imports =

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

86− in f

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

84+imports other =

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

86+ in f other

8787 where

88− collect :: Value -> [ModuleName]

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

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

91− collect _ = []

88+ collectV :: Value -> [ModuleName]

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

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

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

92+ collectV _ = []

93+ collectB :: Binder -> [ModuleName]

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

95+ collectB _ = []

9296

9397-- |

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

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

102106 js <- valueToJs opts mp e val

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

104108 return $ Just jss

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

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

106110 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+ ]

108115 where

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

110− go pn _ [] values =

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

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

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

117+ makeConstructor ctorName n =

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)

124+ go pn index n values =

113125 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))])

115127declToJs opts mp (DataBindingGroupDeclaration ds) e = do

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

117129 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"

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

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

120153declToJs _ _ _ _ = return Nothing

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

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

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

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

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

129163exportToJs _ = []

130164

131165-- |

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

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

146180

147181accessorString :: 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

150184

151185-- |

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

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

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

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

159193valueToJs 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"

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

161199 obj <- valueToJs opts m e o

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

163201 extendObj obj sts

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

202+valueToJs _ m e (Constructor name) =

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

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

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

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

167207 bindersToJs opts m e binders vals

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

297337 then

298338 return js

299339 else

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

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

301341 (JSBlock js)

302342 Nothing]

303343 where

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

307347 argVar <- freshName

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

309349 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)

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

312352 where

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

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

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

358398 typeConstructor _ = error "Invalid argument to isOnlyConstructor"

359399

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

170170 --

171171 | JSApp JS [JS]

172172 -- |

173+ -- Constructor

174+ --

175+ | JSNew JS

176+ -- |

173177 -- Variable

174178 --

175179 | JSVar String

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

218222 --

219223 | JSTypeOf JS

220224 -- |

225+ -- InstanceOf test

226+ --

227+ | JSInstanceOf JS JS

228+ -- |

221229 -- Labelled statement

222230 --

223231 | JSLabel String JS

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

262270 go (JSThrow js) = f (JSThrow (go js))

263271 go (JSTypeOf js) = f (JSTypeOf (go js))

264272 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))

265275 go other = f other

266276

267277everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS

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

288298 go (JSThrow j) = JSThrow (go (f j))

289299 go (JSTypeOf j) = JSTypeOf (go (f j))

290300 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))

291303 go other = f other

292304

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

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

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

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

316328 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

317331 go other = f other

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

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

186186

187187-- Code Generation

188188

189−__superclasses :: String

190−__superclasses = "__superclasses"

189+__superclass_ :: String

190+__superclass_ = "__superclass_"

191191

192192-- Modules

193193

src/Language/PureScript/DeadCodeElimination.hs+2

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

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

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

8282 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"

8385 values _ = []

8486

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

src/Language/PureScript/Declarations.hs+11

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

332332 --

333333 | Do [DoNotationElement]

334334 -- |

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

336+ -- an ObjectLiteral.

337+ --

338+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Value

339+ -- |

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

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

337342 -- 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')

483488 g' (Parens v) = g (Parens (g' v))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

644653 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'

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

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

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

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

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

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

707717 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

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

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

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

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

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

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

772783 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

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

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

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

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

53+ = fn

5254 convert js = js

5355

5456unThunk :: JS -> JS

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

153155 isOp _ = False

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

155157 isOpDict _ _ = False

156−

157158 mkFn :: Int -> JS -> JS

158159 mkFn 0 = everywhereOnJS convert

159160 where

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

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

1818) where

1919

2020import Language.PureScript.Pretty.Common

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

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

2222import Language.PureScript.CodeGen.JS.AST

2323

2424import Data.List

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

5656 ]

5757 where

5858 objectPropertyToString :: String -> String

59− objectPropertyToString s | isIdent s = s

60− | otherwise = show s

59+ objectPropertyToString s | identNeedsEscaping s = show s

60+ | otherwise = s

6161 match (JSBlock sts) = fmap concat $ sequence

6262 [ return "{\n"

6363 , withIndent $ prettyStatements sts

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

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

175175 match _ = Nothing

176176

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+

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

178190unary op str = Wrap match (++)

179191 where

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

222234 operators =

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

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

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

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

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

227240 ++ fromMaybe "" name

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

232245 , [ binary GreaterThan ">" ]

233246 , [ binary GreaterThanOrEqualTo ">=" ]

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

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

235249 , [ unary Not "!" ]

236250 , [ unary BitwiseNot "~" ]

237251 , [ unary Negate "-" ]

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

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

5151 , currentIndent

5252 , return "}"

5353 ]

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

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

56+ , match ps

57+ , return ")"

58+ ]

5459 match (Constructor name) = return $ show name

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

5661 [ return "case "

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

7378 , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

7479 , currentIndent

7580 ]

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

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

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

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

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

7984 match (PositionedValue _ val) = prettyPrintValue' val

8085 match _ = mzero

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

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

8282-- instance subString :: Sub String where

8383-- sub = ""

8484--

85−-- becomes

85+-- becomes:

86+--

87+-- <TypeClassDeclaration Foo ...>

8688--

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

8890--

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

90−-- \ return dict.foo;\

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

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

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

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

95+-- foo dict = dict.foo

9296--

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

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

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

9599--

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

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

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

98102--

99103-- {- Superclasses -}

100104--

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+-- };

102129--

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

104−-- subString _ = {

105−-- __superclasses: {

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

107−-- }

108−-- sub: ""

109−-- }

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

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

132+-- return s + s;

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;

147+-- };

148+--

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

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

151+-- };

110152-}

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

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

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

126168memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

128170

129−identToProperty :: Ident -> String

130−identToProperty (Ident name) = name

131−identToProperty (Op op) = op

132−

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

134172typeClassDictionaryDeclaration name args implies members =

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

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

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

138− , let fieldName = mkSuperclassDictionaryName superclass index

139− ], REmpty))

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

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

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

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

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

176+ , let fieldName = mkSuperclassDictionaryName superclass index

177+ ]

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

179+ mtys = members' ++ superclassTypes

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

143181

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

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

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

152190

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

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

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

155193

156194unit :: Type

157195unit = TypeApp tyObject REmpty

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

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

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

177215 -- 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

179217 -- Create the type of the dictionary

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

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

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

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

184− let superclasses = ObjectLiteral

222+ let superclasses =

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

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

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

188226 , let fieldName = mkSuperclassDictionaryName superclass index

189227 ]

190228

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

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

192230 dictTy = foldl TypeApp (TypeConstructor className) tys

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

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

195−

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

232+ dict = TypeClassDictionaryConstructorApp className memberNames'

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

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

235+ return result

197236

198237 where

199238

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

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

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

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

309309 filterModule _ = False

310−

310+

311311 solve context' (className, tys) trySuperclasses =

312312 let

313313 dicts = go trySuperclasses className tys

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

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

327327 -- Solve any necessary subgoals

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

329−

329+

330330 -- Look for implementations via superclasses

331331 [ SubclassDictionaryValue suDict superclass index

332332 | trySuperclasses'

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

340340 -- Finally, satisfy the subclass constraint

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

342342 , suDict <- go True subclassName args' ]

343−

343+

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

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

346346 -- 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

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

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

362362 dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

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

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

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

364+ (dictionaryValueToValue dict))

365365 (ObjectLiteral [])

366366 -- Ensure that a substitution is valid

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

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

931931 ensureNoDuplicateProperties ps

932932 ps' <- checkProperties ps row False

933933 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

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

935938 ensureNoDuplicateProperties ps

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