git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Ensure exported members don't rely on hidden types
2a89f0aGary Burgess
src/Language/PureScript.hs+46−14
compare with golang
unifiedsplit
@@ -32,13 +32,15 @@ import Language.PureScript.DeadCodeElimination as P
32
32
33import qualified Language.PureScript.Constants as C
33import qualified Language.PureScript.Constants as C
34
34
35−import Data.List (sortBy, groupBy, intercalate)
35+import Data.List (find, sortBy, groupBy, intercalate)
36import Data.Time.Clock
36import Data.Time.Clock
37import Data.Function (on)
37import Data.Function (on)
38+import Data.Generics (mkQ, everything)
38import Data.Maybe (fromMaybe, mapMaybe)
39import Data.Maybe (fromMaybe, mapMaybe)
40+import Control.Monad.Error
39import Control.Monad.State.Lazy
41import Control.Monad.State.Lazy
40import Control.Arrow ((&&&))
42import Control.Arrow ((&&&))
41−import Control.Applicative ((<$>), (<*>), pure)
43+import Control.Applicative ((<$>))
42import qualified Data.Map as M
44import qualified Data.Map as M
43import qualified Data.Set as S
45import qualified Data.Set as S
44import System.FilePath (pathSeparator)
46import System.FilePath (pathSeparator)
@@ -69,9 +71,7 @@ compile' :: Environment -> Options -> [Module] -> Either String (String, String,
69compile' env opts ms = do
71compile' env opts ms = do
70 (sorted, _) <- sortModules (map importPrelude ms)
72 (sorted, _) <- sortModules (map importPrelude ms)
71 desugared <- desugar sorted
73 desugared <- desugar sorted
72− (elaborated, env') <- runCheck' env $ forM desugared $ \(Module moduleName' decls exps) -> do
74+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
73− modify (\s -> s { checkCurrentModule = Just moduleName' })
74− Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps
75 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
75 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
76 let entryPoints = moduleNameFromString `map` optionsModules opts
76 let entryPoints = moduleNameFromString `map` optionsModules opts
77 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
77 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -84,6 +84,42 @@ compile' env opts ms = do
84 where
84 where
85 mainModuleIdent = moduleNameFromString <$> optionsMain opts
85 mainModuleIdent = moduleNameFromString <$> optionsMain opts
86
86
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+
87generateMain :: Environment -> Options -> [JS] -> Either String [JS]
123generateMain :: Environment -> Options -> [JS] -> Either String [JS]
88generateMain env opts js =
124generateMain env opts js =
89 case moduleNameFromString <$> optionsMain opts of
125 case moduleNameFromString <$> optionsMain opts of
@@ -126,7 +162,7 @@ class MonadMake m where
126--
162--
127make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
163make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
128make opts ms = do
164make 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)
130
166
131 (sorted, graph) <- liftError $ sortModules (map (importPrelude . snd) ms)
167 (sorted, graph) <- liftError $ sortModules (map (importPrelude . snd) ms)
132
168
@@ -154,20 +190,16 @@ make opts ms = do
154 where
190 where
155 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
191 go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
156 go _ [] = return ()
192 go _ [] = return ()
157− go env ((False, Module moduleName' typings _) : ms') = do
193+ go env ((False, m) : ms') = do
158− (_, env') <- liftError . runCheck' env $ do
194+ (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
159− modify (\s -> s { checkCurrentModule = Just moduleName' })
160− typeCheckAll Nothing moduleName' typings
161
195
162 go env' ms'
196 go env' ms'
163− go env ((True, Module moduleName' decls exps) : ms') = do
197+ go env ((True, m@(Module moduleName' _ exps)) : ms') = do
164 let filePath = toFileName moduleName'
198 let filePath = toFileName moduleName'
165 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
199 jsFile = "js" ++ pathSeparator : filePath ++ ".js"
166 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
200 externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
167
201
168− (elaborated, env') <- liftError . runCheck' env $ do
202+ (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
169− modify (\s -> s { checkCurrentModule = Just moduleName' })
170− typeCheckAll Nothing moduleName' decls
171
203
172 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
204 regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
173
205