c9ca53b · rowtype-yoga/purescript-native

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

Define type instances without wrapper function

This requires sorting binding groups by their immediate dependencies (those not wrapped in function bodies). This is not perfect, as those functions may be evaluated immediately, but in any generated instance declarations they are not. All test cases passing, though certain types of recursive definitions may not work (can't yet think of any that weren't already broken by #365).

commitc9ca53b8c5785e9525de7ca36c11a2fef6438154 authorDylan Simon <dylan@dylex.net> dateFri 24 Oct 2014, 22:33 (12 years ago) parentfa6bc5f

5 files changed+49−15

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/Optimizer/MagicDo.hs+2−2 src/Language/PureScript/Sugar/BindingGroups.hs+42−5 src/Language/PureScript/Sugar/TypeClasses.hs+3−6 src/Language/PureScript/TypeChecker/Types.hs+1−1

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

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

9494 js <- valueToJs opts mp e val

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

9696declToJs opts mp (BindingGroupDeclaration vals) e = do

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

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

9898 js <- valueToJs opts mp e val

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

100100 return $ Just jss

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

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

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

100100 isEffFunc _ _ = False

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

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

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

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

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

104104 isEffDict _ _ = False

105105 -- Remove __do function applications which remain after desugaring

106106 undo :: JS -> JS

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

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

5858 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

5959 let allIdents = map getIdent values

6060 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

6262 return $ filter isImportDecl ds ++

6363 filter isExternDataDecl ds ++

6464 filter isExternInstanceDecl ds ++

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

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

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

109109

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+

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

111124usedProperNames moduleName =

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

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

131144getProperName (PositionedDeclaration _ d) = getProperName d

132145getProperName _ = error "Expected DataDeclaration"

133146

134−toBindingGroup :: SCC Declaration -> Declaration

135−toBindingGroup (AcyclicSCC d) = d

136−toBindingGroup (CyclicSCC [d]) = d

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

147+-- |

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

149+--

150+--

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

152+toBindingGroup _ (AcyclicSCC d) = return d

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

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

138175

139176toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

140177toDataBindingGroup (AcyclicSCC d) = return d

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

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

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

246246 -- Create the type of the dictionary

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

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.

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

251249 let superclasses =

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

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

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

257255

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

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

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

264261 return result

265262

266263 where

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

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

359359 -- Turn a DictionaryValue into a Expr

360360 dictionaryValueToValue :: DictionaryValue -> Expr

361361 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

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

362+ dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName

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

364364 dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =

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