c9ca53b · rowtype-yoga/purescript-native

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

on golang help sign in

Define type instances without wrapper function

c9ca53bDylan Simon12 years ago

src/Language/PureScript/CodeGen/JS.hs+1−1

compare with golang

unifiedsplit

@@ -94,7 +94,7 @@ declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do

94 js <- valueToJs opts mp e val

95 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

96declToJs opts mp (BindingGroupDeclaration vals) e = do

97− jss <- flip mapM vals $ \(ident, _, val) -> do

97+ jss <- forM vals $ \(ident, _, val) -> do

98 js <- valueToJs opts mp e val

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

100 return $ Just jss

src/Language/PureScript/Optimizer/MagicDo.hs+2−2

@@ -99,8 +99,8 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

99 isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'

100 isEffFunc _ _ = False

101 -- Check if an expression represents the Monad Eff dictionary

102− isEffDict name (JSApp (JSVar ident) []) | ident == name = True

102+ isEffDict name (JSVar ident) | ident == name = True

103− isEffDict name (JSApp (JSAccessor prop (JSVar eff)) []) = eff == C.eff && prop == name

103+ isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name

104 isEffDict _ _ = False

105 -- Remove __do function applications which remain after desugaring

106 undo :: JS -> JS

src/Language/PureScript/Sugar/BindingGroups.hs+42−5

@@ -58,7 +58,7 @@ createBindingGroups moduleName ds = do

58 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

59 let allIdents = map getIdent values

60 valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values

61− bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

61+ bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts

62 return $ filter isImportDecl ds ++

63 filter isExternDataDecl ds ++

64 filter isExternInstanceDecl ds ++

@@ -107,6 +107,19 @@ usedIdents moduleName =

107 usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])

108 usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])

109

110+usedImmediateIdents :: ModuleName -> Declaration -> [Ident]

111+usedImmediateIdents moduleName =

112+ let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def

113+ in nub . f

114+ where

115+ def s _ = (s, [])

116+

117+ usedNamesE :: Bool -> Expr -> (Bool, [Ident])

118+ usedNamesE True (Var (Qualified Nothing name)) = (True, [name])

119+ usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])

120+ usedNamesE True (Abs _ _) = (False, [])

121+ usedNamesE scope _ = (scope, [])

122+

110usedProperNames :: ModuleName -> Declaration -> [ProperName]

123usedProperNames :: ModuleName -> Declaration -> [ProperName]

111usedProperNames moduleName =

124usedProperNames moduleName =

112 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

125 let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)

@@ -131,10 +144,34 @@ getProperName (TypeSynonymDeclaration pn _ _) = pn

131getProperName (PositionedDeclaration _ d) = getProperName d

144getProperName (PositionedDeclaration _ d) = getProperName d

132getProperName _ = error "Expected DataDeclaration"

145getProperName _ = error "Expected DataDeclaration"

133

146

147+-- |

148+-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).

149+--

150+--

134−toBindingGroup :: SCC Declaration -> Declaration

151+toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration

135−toBindingGroup (AcyclicSCC d) = d

152+toBindingGroup _ (AcyclicSCC d) = return d

136−toBindingGroup (CyclicSCC [d]) = d

153+toBindingGroup _ (CyclicSCC [d]) = return d

137−toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

154+toBindingGroup moduleName (CyclicSCC ds') =

155+ -- Once we have a mutually-recursive group of declarations, we need to sort

156+ -- them further by their immediate dependencies (those outside function

157+ -- bodies). In particular, this is relevant for type instance dictionaries

158+ -- whose members require other type instances (for example, functorEff

159+ -- defines (<$>) = liftA1, which depends on applicativeEff). Note that

160+ -- superclass references are still inside functions, so don't count here.

161+ -- If we discover declarations that still contain mutually-recursive

162+ -- immediate references, we're guaranteed to get an undefined reference at

163+ -- runtime, so treat this as an error. See also github issue #365.

164+ BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)

165+ where

166+ idents :: [Ident]

167+ idents = map (\(_, i, _) -> i) valueVerts

168+

169+ valueVerts :: [(Declaration, Ident, [Ident])]

170+ valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

171+

172+ toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)

173+ toBinding (AcyclicSCC d) = return $ fromValueDecl d

174+ toBinding (CyclicSCC ds) = Left $ mkErrorStack ("Cycle in value declarations " ++ unwords (map (show . getIdent) ds)) Nothing

138

175

139toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

176toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

140toDataBindingGroup (AcyclicSCC d) = return d

177toDataBindingGroup (AcyclicSCC d) = return d

src/Language/PureScript/Sugar/TypeClasses.hs+3−6

@@ -245,9 +245,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

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

246 -- Create the type of the dictionary

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

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

248+ -- The dictionary itself is an object literal.

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

250− -- dependencies, we introduce an unnamed function parameter.

251 let superclasses =

249 let superclasses =

252 [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))

250 [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))

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

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

@@ -257,10 +255,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

257

255

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

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

259 dictTy = foldl TypeApp (TypeConstructor className) tys

257 dictTy = foldl TypeApp (TypeConstructor className) tys

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

258+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

261 dict = TypeClassDictionaryConstructorApp className memberNames'

259 dict = TypeClassDictionaryConstructorApp className memberNames'

262− dict' = if null deps then Abs (Left (Ident C.__unused)) dict else dict

263− result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)

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

264 return result

261 return result

265

262

266 where

263 where

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

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

359 -- Turn a DictionaryValue into a Expr

360 dictionaryValueToValue :: DictionaryValue -> Expr

361 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

362− dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined

362+ dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName

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

364 dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

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