@@ -34,6 +34,8 @@ import Language.PureScript.Names
3434import Language.PureScript.Types
3535import Language.PureScript.Values
3636
37+import Language.PureScript.TypeChecker.Monad (jsTypes)
38+
3739-- |
3840-- The global export environment - every declaration exported from every module.
3941--
@@ -138,7 +140,7 @@ desugarImports modules = do
138140 where
139141 renameInModule' exports m = rethrowForModule m $ do
140142 imports <- resolveImports exports m
141− renameInModule imports m
143+ renameInModule imports exports m
142144
143145-- |
144146-- Rethrow an error with the name of the current module in the case of a failure
@@ -147,13 +149,14 @@ rethrowForModule :: Module -> Either String a -> Either String a
147149rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
148150
149151-- |
150−-- Replaces all local names with qualified names within a module.
152+-- Replaces all local names with qualified names within a module and checks that all existing
153+-- qualified names are valid.
151154--
152−renameInModule :: ImportEnvironment -> Module -> Either String Module
153−renameInModule imports (Module mn decls exps) =
155+renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
156+renameInModule imports exports (Module mn decls exps) =
154157 Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
155158 where
156− updateDecl (TypeInstanceDeclaration name cs (Qualified Nothing cn) ts ds) =
159+ updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
157160 TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
158161 updateDecl d = return d
159162
@@ -162,43 +165,69 @@ renameInModule imports (Module mn decls exps) =
162165 ValueDeclaration name [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
163166 where
164167 bindFunctionArgs bound (Abs (Left arg) val) = return (arg : bound, Abs (Left arg) val)
165− bindFunctionArgs bound (Var (Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName ident)
168+ bindFunctionArgs bound (Var name@(Qualified Nothing ident)) | ident `notElem` bound = (,) bound <$> (Var <$> updateValueName name)
169+ bindFunctionArgs bound (Var name@(Qualified (Just _) _)) = (,) bound <$> (Var <$> updateValueName name)
166170 bindFunctionArgs bound other = return (bound, other)
167171 bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
168172 bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
169173 updateVars (ValueDeclaration name _ _ _) = error $ "Binders should have been desugared in " ++ show name
170174 updateVars other = return other
171−
172− updateValue (Constructor (Qualified Nothing nm)) =
173− Constructor <$> updateDataConstructorName nm
175+ updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
174176 updateValue v = return v
175−
176− updateBinder (ConstructorBinder (Qualified Nothing nm) b) =
177− ConstructorBinder <$> updateDataConstructorName nm <*> pure b
177+ updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
178178 updateBinder v = return v
179− updateType (TypeConstructor (Qualified Nothing nm)) =
180− TypeConstructor <$> updateTypeName nm
181− updateType (SaturatedTypeSynonym (Qualified Nothing nm) tys) =
182− SaturatedTypeSynonym <$> updateTypeName nm <*> mapM updateType tys
183− updateType (ConstrainedType cs t) =
184− ConstrainedType <$> updateConstraints cs <*> pure t
179+ updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
180+ updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
181+ updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
185182 updateType t = return t
186− updateConstraints = mapM updateConstraint
187− updateConstraint (Qualified Nothing nm, ts) = (,) <$> updateClassName nm <*> pure ts
188− updateConstraint other = return other
189− updateTypeName = update "type" importedTypes
190− updateClassName = update "type class" importedTypeClasses
191− updateValueName = update "value" importedValues
192− updateDataConstructorName = update "data constructor" importedDataConstructors
193− update t get nm = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show nm ++ "'") return $ M.lookup nm (get imports)
183+ updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
184+
185+ updateTypeName (Qualified Nothing name) = update "type" importedTypes name
186+ updateTypeName (Qualified (Just mn) name) = do
187+ modExports <- getExports mn
188+ case name `lookup` (S.toList (exportedTypes modExports)) of
189+ Nothing -> throwError $ "Unknown type '" ++ show (Qualified (Just mn) name) ++ "'"
190+ _ -> return $ Qualified (Just mn) name
191+
192+ updateDataConstructorName (Qualified Nothing name) = update "data constructor" importedDataConstructors name
193+ updateDataConstructorName (Qualified (Just mn) name) = do
194+ modExports <- getExports mn
195+ let allDcons = join (snd `map` (S.toList $ exportedTypes modExports))
196+ if name `elem` allDcons
197+ then return $ Qualified (Just mn) name
198+ else throwError $ "Unknown data constructor '" ++ show (Qualified (Just mn) name) ++ "'"
199+
200+ updateClassName (Qualified Nothing name) = update "type class" importedTypeClasses name
201+ updateClassName (Qualified (Just mn) name) = check "type class" exportedTypeClasses mn name
202+
203+ updateValueName (Qualified Nothing name) = update "value" importedValues name
204+ updateValueName (Qualified (Just mn) name) = check "value" exportedValues mn name
205+
206+ -- Replace an unqualified name with a qualified
207+ update :: (Show a, Ord a) => String -> (ImportEnvironment -> M.Map a (Qualified a)) -> a -> Either String (Qualified a)
208+ update t get name = maybe (throwError $ "Unknown " ++ t ++ " '" ++ show name ++ "'") return $ M.lookup name (get imports)
209+
210+ -- Check that a qualified name is valid
211+ check :: (Show a, Ord a) => String -> (Exports -> S.Set a) -> ModuleName -> a -> Either String (Qualified a)
212+ check t get mn name = do
213+ modExports <- getExports mn
214+ if name `S.member` (get modExports)
215+ then return $ Qualified (Just mn) name
216+ else throwError $ "Unknown " ++ t ++ " '" ++ show (Qualified (Just mn) name) ++ "'"
217+
218+ -- Gets the exports for a module, or an error message if the module doesn't exist
219+ getExports :: ModuleName -> Either String Exports
220+ getExports mn = maybe (throwError $ "Unknown module '" ++ show mn ++ "'") return $ M.lookup mn exports
194221
195222-- |
196223-- Finds all exported declarations in a set of modules.
197224--
198225findExports :: [Module] -> Either String ExportEnvironment
199−findExports = foldM addModule M.empty
226+findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) primExports
200227 where
201228
229+ primExports = Exports (S.fromList $ (\(Qualified _ name) -> (name, [])) `map` (M.keys jsTypes)) S.empty S.empty
230+
202231 -- Add all of the exported declarations from a module to the global export environment
203232 addModule :: ExportEnvironment -> Module -> Either String ExportEnvironment
204233 addModule env m@(Module mn ds Nothing) = rethrowForModule m $ foldM (addDecl mn) (addEmptyModule env mn) ds