4dbd9f9 · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #648 from dylex/imminstance

4dbd9f9Phil Freeman12 years ago

examples/failing/Foldable.pursnew file+12

compare with golang

unifiedsplit

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

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

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

24import Data.Graph

25import Data.List (nub, intersect)

26import Data.Maybe (isJust, mapMaybe)

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

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

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

29import qualified Data.Set as S

30import qualified Data.Set as S

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

58 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

59 dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts

59 let allIdents = map getIdent values

60 let allIdents = map getIdent values

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

61 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

62 return $ filter isImportDecl ds ++

63 return $ filter isImportDecl ds ++

63 filter isExternDataDecl ds ++

64 filter isExternDataDecl ds ++

64 filter isExternInstanceDecl ds ++

65 filter isExternInstanceDecl ds ++

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

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

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

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

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

109

110

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+

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

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

111usedProperNames moduleName =

125usedProperNames moduleName =

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

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

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

131getProperName (PositionedDeclaration _ d) = getProperName d

145getProperName (PositionedDeclaration _ d) = getProperName d

132getProperName _ = error "Expected DataDeclaration"

146getProperName _ = error "Expected DataDeclaration"

133

147

148+-- |

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

150+--

151+--

134−toBindingGroup :: SCC Declaration -> Declaration

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

135−toBindingGroup (AcyclicSCC d) = d

153+toBindingGroup _ (AcyclicSCC d) = return d

136−toBindingGroup (CyclicSCC [d]) = d

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

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

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+

138

184

139toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

185toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration

140toDataBindingGroup (AcyclicSCC d) = return d

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