3634a8d · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #640 from purescript/check-exports

3634a8dPhil Freeman12 years ago

examples/failing/MissingClassExport.pursnew file+4

compare with golang

unifiedsplit

@@ -0,0 +1,4 @@

1+module Test (bar) where

3+ class Foo a where

4+ bar :: a -> a

examples/failing/MissingClassMemberExport.pursnew file+4

@@ -0,0 +1,4 @@

1+module Test (Foo) where

3+ class Foo a where

4+ bar :: a -> a

src/Language/PureScript.hs+1−39

@@ -38,12 +38,11 @@ import Language.PureScript.Renamer as P

38import qualified Language.PureScript.Constants as C

39import qualified Paths_purescript as Paths

41−import Data.List (find, sortBy, groupBy, intercalate)

41+import Data.List (sortBy, groupBy, intercalate)

42import Data.Time.Clock

43import Data.Function (on)

44import Data.Maybe (listToMaybe, fromMaybe)

45import Control.Monad.Error

46−import Control.Monad.State.Lazy

47import Control.Arrow ((&&&))

46import Control.Arrow ((&&&))

48import Control.Applicative

47import Control.Applicative

49import qualified Data.Map as M

48import qualified Data.Map as M

@@ -93,43 +92,6 @@ compile' env opts ms prefix = do

93 where

92 where

94 mainModuleIdent = moduleNameFromString <$> optionsMain opts

93 mainModuleIdent = moduleNameFromString <$> optionsMain opts

96−typeCheckModule :: Maybe ModuleName -> Module -> Check Module

97−typeCheckModule mainModuleName (Module mn decls exps) = do

98− modify (\s -> s { checkCurrentModule = Just mn })

99− decls' <- typeCheckAll mainModuleName mn exps decls

100− mapM_ checkTypesAreExported exps'

101− return $ Module mn decls' exps

102− where

103−

104− exps' = fromMaybe (error "exports should have been elaborated") exps

105−

106− -- Check that all the type constructors defined in the current module that appear in member types

107− -- have also been exported from the module

108− checkTypesAreExported :: DeclarationRef -> Check ()

109− checkTypesAreExported (ValueRef name) = do

110− ty <- lookupVariable mn (Qualified (Just mn) name)

111− case find isTconHidden (findTcons ty) of

112− Just hiddenType -> throwError . strMsg $

113− "Error in module '" ++ show mn ++ "':\n\

114− \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"

115− Nothing -> return ()

116− checkTypesAreExported _ = return ()

117−

118− -- Find the type constructors exported from the current module used in a type

119− findTcons :: Type -> [ProperName]

120− findTcons = everythingOnTypes (++) go

121− where

122− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]

123− go _ = []

124−

125− -- Checks whether a type constructor is not being exported from the current module

126− isTconHidden :: ProperName -> Bool

127− isTconHidden tyName = all go exps'

128− where

129− go (TypeRef tyName' _) = tyName' /= tyName

130− go _ = True

131−

132−

133generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]

95generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]

134generateMain env opts js =

96generateMain env opts js =

135 case moduleNameFromString <$> optionsMain opts of

97 case moduleNameFromString <$> optionsMain opts of

src/Language/PureScript/TypeChecker.hs+86−7

@@ -17,7 +17,7 @@

18module Language.PureScript.TypeChecker (

19 module T,

20− typeCheckAll

20+ typeCheckModule

21) where

23import Language.PureScript.TypeChecker.Monad as T

@@ -26,7 +26,7 @@ import Language.PureScript.TypeChecker.Types as T

26import Language.PureScript.TypeChecker.Synonyms as T

28import Data.Maybe

29−import Data.List (nub, (\\))

29+import Data.List (nub, (\\), find, intercalate)

30import Data.Monoid ((<>))

31import Data.Foldable (for_)

32import qualified Data.Map as M

@@ -119,7 +119,7 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea

119--

120-- * Process module imports

121--

122−typeCheckAll :: Maybe ModuleName -> ModuleName -> Maybe [DeclarationRef] -> [Declaration] -> Check [Declaration]

122+typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]

123typeCheckAll mainModuleName moduleName exps = go

124 where

125 go :: [Declaration] -> Check [Declaration]

@@ -219,7 +219,7 @@ typeCheckAll mainModuleName moduleName exps = go

219 addTypeClass moduleName pn args implies tys

220 ds <- go rest

221 return $ d : ds

222− go (TypeInstanceDeclaration dictName deps className tys _ : rest) = do

222+ go (TypeInstanceDeclaration dictName deps className tys _ : rest) =

223 go (ExternInstanceDeclaration dictName deps className tys : rest)

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

225 mapM_ (checkTypeClassInstance moduleName) tys

@@ -229,18 +229,97 @@ typeCheckAll mainModuleName moduleName exps = go

229 return $ d : ds

230 where

231 isInstanceExported :: Bool

232− isInstanceExported = maybe True (any exportsInstance) exps

232+ isInstanceExported = any exportsInstance exps

233−

233+

234 exportsInstance :: DeclarationRef -> Bool

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

236 exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

237 exportsInstance _ = False

238−

238+

239 go (PositionedDeclaration pos d : rest) =

240 rethrowWithPosition pos $ do

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

242 return (PositionedDeclaration pos d' : rest')

243

244+-- |

245+-- Type check an entire module and ensure all types and classes defined within the module that are

246+-- required by exported members are also exported.

247+--

248+typeCheckModule :: Maybe ModuleName -> Module -> Check Module

249+typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"

250+typeCheckModule mainModuleName (Module mn decls (Just exps)) = do

251+ modify (\s -> s { checkCurrentModule = Just mn })

252+ decls' <- typeCheckAll mainModuleName mn exps decls

253+ forM_ exps $ \e -> do

254+ checkTypesAreExported e

255+ checkClassMembersAreExported e

256+ checkClassesAreExported e

257+ return $ Module mn decls' (Just exps)

258+ where

244

259

260+ checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()

261+ checkMemberExport thing extract test (ValueRef name) = do

262+ ty <- lookupVariable mn (Qualified (Just mn) name)

263+ case find test (extract ty) of

264+ Just hiddenType -> throwError . strMsg $

265+ "Error in module '" ++ show mn ++ "':\n\

266+ \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"

267+ Nothing -> return ()

268+ checkMemberExport _ _ _ _ = return ()

245

269

270+ -- Check that all the type constructors defined in the current module that appear in member types

271+ -- have also been exported from the module

272+ checkTypesAreExported :: DeclarationRef -> Check ()

273+ checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden

274+ where

275+ findTcons :: Type -> [ProperName]

276+ findTcons = everythingOnTypes (++) go

277+ where

278+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]

279+ go _ = []

280+ isTconHidden :: ProperName -> Bool

281+ isTconHidden tyName = all go exps

282+ where

283+ go (TypeRef tyName' _) = tyName' /= tyName

284+ go _ = True

285+

286+ -- Check that all the classes defined in the current module that appear in member types have also

287+ -- been exported from the module

288+ checkClassesAreExported :: DeclarationRef -> Check ()

289+ checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden

290+ where

291+ findClasses :: Type -> [ProperName]

292+ findClasses = everythingOnTypes (++) go

293+ where

294+ go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs

295+ go _ = []

296+ extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName

297+ extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

298+ extractCurrentModuleClass _ = Nothing

299+ isClassHidden :: ProperName -> Bool

300+ isClassHidden clsName = all go exps

301+ where

302+ go (TypeClassRef clsName') = clsName' /= clsName

303+ go _ = True

246

304

305+ checkClassMembersAreExported :: DeclarationRef -> Check ()

306+ checkClassMembersAreExported (TypeClassRef name) = do

307+ let members = ValueRef `map` head (mapMaybe findClassMembers decls)

308+ let missingMembers = members \\ exps

309+ unless (null missingMembers) $

310+ throwError . strMsg $

311+ "Error in module '" ++ show mn ++ "':\n\

312+ \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"

313+ where

314+ runValueRef :: DeclarationRef -> Ident

315+ runValueRef (ValueRef refName) = refName

316+ runValueRef _ = error "non-ValueRef passed to runValueRef"

317+ findClassMembers :: Declaration -> Maybe [Ident]

318+ findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds

319+ findClassMembers (PositionedDeclaration _ d) = findClassMembers d

320+ findClassMembers _ = Nothing

321+ extractMemberName :: Declaration -> Ident

322+ extractMemberName (PositionedDeclaration _ d) = extractMemberName d

323+ extractMemberName (TypeDeclaration memberName _) = memberName

324+ extractMemberName _ = error "Unexpected declaration in typeclass member list"

325+ checkClassMembersAreExported _ = return ()