1baf09e · rowtype-yoga/purescript-native

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

on golang help sign in

Fix #594

1baf09ePhil Freeman12 years ago

src/Language/PureScript/Sugar/TypeClasses.hs+26−14

compare with golang

unifiedsplit

@@ -151,36 +151,46 @@ desugarModule _ = error "Exports should have been elaborated in name desugaring"

151-- };

152-}

153desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])

154−desugarDecl mn _ d@(TypeClassDeclaration name args implies members) = do

154+desugarDecl mn exps = go

155− modify (M.insert (mn, name) d)

156− return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

157−desugarDecl mn exps d@(TypeInstanceDeclaration name deps className tys members) = do

158− desugared <- lift $ desugarCases members

159− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

160− let expRef = if isExportedClass className && all isExportedType (getConstructors `concatMap` tys)

161− then Just $ TypeInstanceRef name

162− else Nothing

163− return $ (expRef, [d, dictDecl])

164 where

155 where

156+ go d@(TypeClassDeclaration name args implies members) = do

157+ modify (M.insert (mn, name) d)

158+ return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)

159+ go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])

160+ go d@(TypeInstanceDeclaration name deps className tys members) = do

161+ desugared <- lift $ desugarCases members

162+ dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

163+ return $ (expRef name className tys, [d, dictDecl])

164+ go (PositionedDeclaration pos d) = do

165+ (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d

166+ return (dr, map (PositionedDeclaration pos) ds)

167+ go other = return (Nothing, [other])

168+

169+ expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef

170+ expRef name className tys

171+ | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name

172+ | otherwise = Nothing

173+

165 isExportedClass :: Qualified ProperName -> Bool

174 isExportedClass :: Qualified ProperName -> Bool

166 isExportedClass = isExported (elem . TypeClassRef)

175 isExportedClass = isExported (elem . TypeClassRef)

176+

167 isExportedType :: Qualified ProperName -> Bool

177 isExportedType :: Qualified ProperName -> Bool

168 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

178 isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)

179+

169 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

180 isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool

170 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

181 isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps

171 isExported _ _ = error "Names should have been qualified in name desugaring"

182 isExported _ _ = error "Names should have been qualified in name desugaring"

183+

172 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

184 matchesTypeRef :: ProperName -> DeclarationRef -> Bool

173 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

185 matchesTypeRef pn (TypeRef pn' _) = pn == pn'

174 matchesTypeRef _ _ = False

186 matchesTypeRef _ _ = False

187+

175 getConstructors :: Type -> [Qualified ProperName]

188 getConstructors :: Type -> [Qualified ProperName]

176 getConstructors = everythingOnTypes (++) getConstructor

189 getConstructors = everythingOnTypes (++) getConstructor

190+

177 getConstructor :: Type -> [Qualified ProperName]

191 getConstructor :: Type -> [Qualified ProperName]

178 getConstructor (TypeConstructor tcname) = [tcname]

192 getConstructor (TypeConstructor tcname) = [tcname]

179 getConstructor _ = []

193 getConstructor _ = []

180−desugarDecl mn exps (PositionedDeclaration pos d) = do

181− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d

182− return (dr, map (PositionedDeclaration pos) ds)

183−desugarDecl _ _ other = return (Nothing, [other])

184

194

185memberToNameAndType :: Declaration -> (Ident, Type)

195memberToNameAndType :: Declaration -> (Ident, Type)

186memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

196memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

@@ -275,3 +285,5 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

275 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val

285 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val

276 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

286 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

277 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"

287 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"

288+

289+

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

@@ -210,6 +210,7 @@ typeCheckAll mainModuleName moduleName exps = go

210 let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds

211 addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }

212 | tcd <- instances

213+ , tcdExported tcd

213 , let (Qualified _ ident) = tcdName tcd

214 , let (Qualified _ ident) = tcdName tcd

214 ]

215 ]

215 ds <- go rest

216 ds <- go rest

@@ -223,11 +224,23 @@ typeCheckAll mainModuleName moduleName exps = go

223 go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

224 go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

224 mapM_ (checkTypeClassInstance moduleName) tys

225 mapM_ (checkTypeClassInstance moduleName) tys

225 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

226 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

226− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

227+ addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]

227 ds <- go rest

228 ds <- go rest

228 return $ d : ds

229 return $ d : ds

230+ where

231+ isInstanceExported :: Bool

232+ isInstanceExported = maybe True (any exportsInstance) exps

233+

234+ exportsInstance :: DeclarationRef -> Bool

235+ exportsInstance (TypeInstanceRef name) | name == dictName = True

236+ exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

237+ exportsInstance _ = False

238+

229 go (PositionedDeclaration pos d : rest) =

239 go (PositionedDeclaration pos d : rest) =

230 rethrowWithPosition pos $ do

240 rethrowWithPosition pos $ do

231 (d' : rest') <- go (d : rest)

241 (d' : rest') <- go (d : rest)

232 return (PositionedDeclaration pos d' : rest')

242 return (PositionedDeclaration pos d' : rest')

233

243

244+

245+

246+

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

@@ -863,7 +863,7 @@ check' val t@(ConstrainedType constraints ty) = do

863 n <- liftCheck freshDictionaryName

864 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

865 val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

866− TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

866+ TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)

867 constraints) $ check val ty

868 return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

869check' val (SaturatedTypeSynonym name args) = do

@@ -1146,3 +1146,4 @@ meet e1 e2 t1 t2 = do

1146

1147

1148

1149+

src/Language/PureScript/TypeClassDictionaries.hs+4

@@ -46,6 +46,10 @@ data TypeClassDictionaryInScope

46 -- The type of this dictionary

47 --

48 , tcdType :: TypeClassDictionaryType

49+ -- |

50+ -- Is this instance exported by its module?

51+ --

52+ , tcdExported :: Bool

49 } deriving (Show, Data, Typeable)

53 } deriving (Show, Data, Typeable)

51-- |

55-- |