6ad7aa1 · rowtype-yoga/purescript-native

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

on golang help sign in

Generate prototypes for typeclasses

6ad7aa1Gary Burgess12 years ago

examples/passing/TypeClassMemberOrderChange.pursnew file+11

compare with golang

unifiedsplit

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

src/Language/PureScript/CodeGen/Common.hs+2−3

@@ -131,11 +131,10 @@ nameIsJsReserved name =

131 , "yield" ]

132

133-- |

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

134+-- Test if a string is a valid JS identifier.

135--

136isIdent :: String -> Bool

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

137+isIdent s = identToJs (Ident s) == s

138−isIdent _ = False

139

138

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+32−6

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

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

@@ -89,6 +88,7 @@ imports other =

89 collectV :: Value -> [ModuleName]

88 collectV :: Value -> [ModuleName]

90 collectV (Var (Qualified (Just mn) _)) = [mn]

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

91 collectV (Constructor (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]

@@ -109,16 +109,16 @@ declToJs opts mp (BindingGroupDeclaration vals) e = do

109declToJs _ _ (DataDeclaration _ _ ctors) _ = do

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

111 let _ctor = '_' : ctor

112− in [ JSVariableIntroduction _ctor (Just (makeConstructor (length tys)))

112+ in [ makeConstructor _ctor (length tys)

113 , JSVariableIntroduction ctor (Just (go pn 0 (length tys) []))

114 ]

115 where

116− makeConstructor :: Int -> JS

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

117− makeConstructor n =

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 Nothing args (JSBlock body)

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 =

@@ -127,6 +127,27 @@ declToJs _ _ (DataDeclaration _ _ ctors) _ = do

127declToJs opts mp (DataBindingGroupDeclaration ds) e = do

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

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"

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

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

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

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

132declToJs _ _ _ _ = return Nothing

153declToJs _ _ _ _ = return Nothing

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

138exportToJs (TypeRef _ (Just dctors)) = concatMap ((\n -> [('_' : n, var (Ident ('_' : n))), (n, var (Ident n))]) . runProperName) dctors

159exportToJs (TypeRef _ (Just dctors)) = concatMap ((\n -> [('_' : n, var (Ident ('_' : n))), (n, var (Ident n))]) . runProperName) dctors

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

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

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

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

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

141exportToJs _ = []

163exportToJs _ = []

142

164

143-- |

165-- |

@@ -169,6 +191,10 @@ valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

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

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

170valueToJs 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

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

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

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

173 obj <- valueToJs opts m e o

199 obj <- valueToJs opts m e o

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

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

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+3−2

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

@@ -170,7 +171,7 @@ inlineCommonOperators = applyAll $

170 Nothing -> orig

171 Nothing -> orig

171 convert other = other

172 convert other = other

172 collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

173 collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

173− collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

174+ collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

174 collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret

175 collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret

175 collectArgs _ _ _ = Nothing

176 collectArgs _ _ _ = Nothing

176

177

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+15−18

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

126memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

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

128

129−identToProperty :: Ident -> String

130−identToProperty (Ident name) = name

131−identToProperty (Op op) = op

132−

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

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

134typeClassDictionaryDeclaration name args implies members =

130typeClassDictionaryDeclaration name args implies members =

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

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

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

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

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

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

138− , let fieldName = mkSuperclassDictionaryName superclass index

134+ , let fieldName = mkSuperclassDictionaryName superclass index

139− ], REmpty))

135+ ]

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

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

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

137+ mtys = members' ++ superclassTypes

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

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

143

139

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

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

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

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

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

152

148

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

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

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

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

155

151

156unit :: Type

152unit :: Type

157unit = TypeApp tyObject REmpty

153unit = TypeApp tyObject REmpty

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

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

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

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

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

177 -- Create values for the type instance members

173 -- Create values for the type instance members

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

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

179 -- Create the type of the dictionary

175 -- Create the type of the dictionary

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

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

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

178 -- 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.

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

184− let superclasses = ObjectLiteral

180+ let superclasses =

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

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

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

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

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

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

188 , let fieldName = mkSuperclassDictionaryName superclass index

184 , let fieldName = mkSuperclassDictionaryName superclass index

189 ]

185 ]

190

186

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

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

192 dictTy = foldl TypeApp (TypeConstructor className) tys

188 dictTy = foldl TypeApp (TypeConstructor className) tys

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

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

190+ dict = TypeClassDictionaryConstructorApp className memberNames'

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

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

195−

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

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

193+ return result

197

194

198 where

195 where

199

196

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

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

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

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

319 filterModule _ = False

320−

320+

321 solve context' (className, tys) trySuperclasses =

322 let

323 dicts = go trySuperclasses className tys

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

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

337 -- Solve any necessary subgoals

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

339−

339+

340 -- Look for implementations via superclasses

341 [ SubclassDictionaryValue suDict superclass index

342 | trySuperclasses'

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

350 -- Finally, satisfy the subclass constraint

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

352 , suDict <- go True subclassName args' ]

353−

353+

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

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

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

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

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

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

372 dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

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

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

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

374+ (dictionaryValueToValue dict))

375 (ObjectLiteral [])

376 -- Ensure that a substitution is valid

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

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

939 ensureNoDuplicateProperties ps

940 ps' <- checkProperties ps row False

941 return $ TypedValue True (ObjectLiteral ps') t

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

943+ ps' <- check' ps t

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

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

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

943 ensureNoDuplicateProperties ps

946 ensureNoDuplicateProperties ps

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

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