13b91bb · rowtype-yoga/purescript-native

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

Add superclass dictionaries

commit13b91bb82e06952f821d5bc1a30f6981db7fb5be authorPhil Freeman <paf31@cantab.net> dateSat 5 Apr 2014, 17:02 (13 years ago) parent0b890e7

2 files changed+20−4

compare with golang

unifiedsplit

examples/passing/Superclasses.purs+12 src/Language/PureScript/Sugar/TypeClasses.hs+8−4

examples/passing/Superclasses.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class Su a where

4+ su :: a -> a

6+class (Su a) <= Cl a where

7+ cl :: a -> a -> a

9+test :: forall a. (Cl a) => a -> a

10+test a = su (cl a a)

11+

12+main = Debug.Trace.trace "Done"

src/Language/PureScript/Sugar/TypeClasses.hs+8−4

@@ -124,10 +124,13 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

124124 m <- get

125125

126126 -- Lookup the type arguments and member types for the type class

127− (TypeClassDeclaration _ args implies tyDecls) <- lift $ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right

128− $ M.lookup (qualify mn className) m

127+ (TypeClassDeclaration _ args implies tyDecls) <- lift $

128+ maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $

129+ M.lookup (qualify mn className) m

129130 let instanceTys = map memberToNameAndType tyDecls

130131

132+ let superclasses = TypedValue False (ArrayLiteral [ TypeClassDictionary (superclass, tyArgs) [] | (superclass, tyArgs) <- implies ]) (TypeApp tyArray unit)

133+

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

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

133136 -- Create values for the type instance members

@@ -137,9 +140,10 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

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

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

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

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

143+ let dictTy = TypeApp tyObject (rowFromList (map (first identToProperty) memberTypes, RCons "__superclasses" (TypeApp tyArray unit) REmpty))

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

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

145+ memberNames' = ("__superclasses", superclasses) : memberNames

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

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

144148 where

145149 unit :: Type