4dbd9f9 · rowtype-yoga/purescript-native

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

Merge pull request #648 from dylex/imminstance

Define type instances without wrapper function

commit4dbd9f94798b5c3f948231015bbb8f6dce75b991 authorPhil Freeman <paf31@cantab.net> dateTue 28 Oct 2014, 20:05 (12 years ago) parent4423b8c 727f1f9

6 files changed+70−15

compare with golang

unifiedsplit

examples/failing/Foldable.purs+12 src/Language/PureScript/CodeGen/JS.hs+1−1 src/Language/PureScript/Optimizer/MagicDo.hs+2−2 src/Language/PureScript/Sugar/BindingGroups.hs+51−5 src/Language/PureScript/Sugar/TypeClasses.hs+3−6 src/Language/PureScript/TypeChecker/Types.hs+1−1

examples/failing/Foldable.pursnew file+12

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

1+module Main where

3+class Foldable f where

4+ fold :: forall a b. (a -> b -> b) -> b -> f a -> b

5+ size :: forall a. f a -> Number

7+instance foldableArray :: Foldable [] where

8+ fold _ z [] = z

9+ fold f z (x:xs) = x `f` (fold f z xs)

10+ size = fold (const ((+) 1)) 0

11+

12+x = size [1,2,3]

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+51−5

@@ -24,6 +24,7 @@ module Language.PureScript.Sugar.BindingGroups (

2424import Data.Graph

2525import Data.List (nub, intersect)

2626import Data.Maybe (isJust, mapMaybe)

27+import Data.Monoid ((<>))

2728import Control.Applicative ((<$>), (<*>), pure)

2829

2930import qualified Data.Set as S

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

5859 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

5960 let allIdents = map getIdent values

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

61− bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts

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

6263 return $ filter isImportDecl ds ++

6364 filter isExternDataDecl ds ++

6465 filter isExternInstanceDecl ds ++

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

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

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

109110

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

112+usedImmediateIdents moduleName =

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

114+ in nub . f

115+ where

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

117+

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

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

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

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

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

123+

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

111125usedProperNames moduleName =

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

@@ -131,10 +145,42 @@ getProperName (TypeSynonymDeclaration pn _ _) = pn

131145getProperName (PositionedDeclaration _ d) = getProperName d

132146getProperName _ = error "Expected DataDeclaration"

133147

134−toBindingGroup :: SCC Declaration -> Declaration

135−toBindingGroup (AcyclicSCC d) = d

136−toBindingGroup (CyclicSCC [d]) = d

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

148+-- |

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

150+--

151+--

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

153+toBindingGroup _ (AcyclicSCC d) = return d

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

155+toBindingGroup moduleName (CyclicSCC ds') =

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

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

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

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

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

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

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

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

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

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

166+ where

167+ idents :: [Ident]

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

169+

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

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

172+

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

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

175+ toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

176+

177+ cycleError :: Declaration -> [Declaration] -> Either ErrorStack a

178+ cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds

179+ cycleError (ValueDeclaration n _ _ _ e) [] = Left $

180+ mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))

181+ cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []

182+ cycleError _ _ = error "Expected ValueDeclaration"

183+

138184

139185toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

140186toDataBindingGroup (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)