@@ -32,13 +32,15 @@ import Language.PureScript.DeadCodeElimination as P
3232
3333import qualified Language.PureScript.Constants as C
3434
35−import Data.List (sortBy, groupBy, intercalate)
35+import Data.List (find, sortBy, groupBy, intercalate)
3636import Data.Time.Clock
3737import Data.Function (on)
38+import Data.Generics (mkQ, everything)
3839import Data.Maybe (fromMaybe, mapMaybe)
40+import Control.Monad.Error
3941import Control.Monad.State.Lazy
4042import Control.Arrow ((&&&))
41−import Control.Applicative ((<$>), (<*>), pure)
43+import Control.Applicative ((<$>))
4244import qualified Data.Map as M
4345import qualified Data.Set as S
4446import System.FilePath (pathSeparator)
@@ -69,9 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,
6971compile' env opts ms = do
7072 (sorted, _) <- sortModules (map importPrelude ms)
7173 desugared <- desugar sorted
72− (elaborated, env') <- runCheck' env $ forM desugared $ \(Module moduleName' decls exps) -> do
73− modify (\s -> s { checkCurrentModule = Just moduleName' })
74− Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps
74+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
7575 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
7676 let entryPoints = moduleNameFromString `map` optionsModules opts
7777 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -84,6 +84,42 @@ compile' env opts ms = do
8484 where
8585 mainModuleIdent = moduleNameFromString <$> optionsMain opts
8686
87+typeCheckModule :: Maybe ModuleName -> Module -> Check Module
88+typeCheckModule mainModuleName (Module mn decls exps) = do
89+ modify (\s -> s { checkCurrentModule = Just mn })
90+ decls' <- typeCheckAll mainModuleName mn decls
91+ mapM_ checkTypesAreExported exps'
92+ return $ Module mn decls' exps
93+ where
94+
95+ exps' = fromMaybe (error "exports should have been elaborated") exps
96+
97+ -- Check that all the type constructors defined in the current module that appear in member types
98+ -- have also been exported from the module
99+ checkTypesAreExported :: DeclarationRef -> Check ()
100+ checkTypesAreExported (ValueRef name) = do
101+ ty <- lookupVariable mn (Qualified (Just mn) name)
102+ case find isTconHidden (findTcons ty) of
103+ Just hiddenType -> throwError $ "Error in module '" ++ show mn ++ "':\n\
104+ \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
105+ Nothing -> return ()
106+ checkTypesAreExported _ = return ()
107+
108+ -- Find the type constructors exported from the current module used in a type
109+ findTcons :: Type -> [ProperName]
110+ findTcons = everything (++) (mkQ [] go)
111+ where
112+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
113+ go _ = []
114+
115+ -- Checks whether a type constructor is not being exported from the current module
116+ isTconHidden :: ProperName -> Bool
117+ isTconHidden tyName = all go exps'
118+ where
119+ go (TypeRef tyName' _) = tyName' /= tyName
120+ go _ = True
121+
122+
87123generateMain :: Environment -> Options -> [JS] -> Either String [JS]
88124generateMain env opts js =
89125 case moduleNameFromString <$> optionsMain opts of
@@ -126,7 +162,7 @@ class MonadMake m where
126162--
127163make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
128164make opts ms = do
129− let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms)
165+ let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
130166
131167 (sorted, graph) <- liftError $ sortModules (map (importPrelude . snd) ms)
132168
@@ -154,20 +190,16 @@ make opts ms = do
154190 where
155191 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
156192 go _ [] = return ()
157− go env ((False, Module moduleName' typings _) : ms') = do
158− (_, env') <- liftError . runCheck' env $ do
159− modify (\s -> s { checkCurrentModule = Just moduleName' })
160− typeCheckAll Nothing moduleName' typings
193+ go env ((False, m) : ms') = do
194+ (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
161195
162196 go env' ms'
163− go env ((True, Module moduleName' decls exps) : ms') = do
197+ go env ((True, m@(Module moduleName' _ exps)) : ms') = do
164198 let filePath = toFileName moduleName'
165199 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
166200 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
167201
168− (elaborated, env') <- liftError . runCheck' env $ do
169− modify (\s -> s { checkCurrentModule = Just moduleName' })
170− typeCheckAll Nothing moduleName' decls
202+ (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
171203
172204 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
173205