@@ -26,8 +26,9 @@ import Language.PureScript.TypeChecker.Types as T
2626import Language.PureScript.TypeChecker.Synonyms as T
2727
2828import Data.Maybe
29−import Data.List (nub, (\\), find, intercalate)
29+import Data.List (nub, (\\))
3030import Data.Foldable (for_)
31+
3132import qualified Data.Map as M
3233
3334import Control.Monad.State
@@ -46,7 +47,7 @@ addDataType moduleName dtype name args dctors ctorKind = do
4647 env <- getEnv
4748 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
4849 forM_ dctors $ \(dctor, tys) ->
49− rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $
50+ rethrow (onErrorMessages (ErrorInDataConstructor dctor)) $
5051 addDataConstructor moduleName dtype name (map fst args) dctor tys
5152
5253addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
@@ -70,7 +71,7 @@ valueIsNotDefined :: ModuleName -> Ident -> Check ()
7071valueIsNotDefined moduleName name = do
7172 env <- getEnv
7273 case M.lookup (moduleName, name) (names env) of
73− Just _ -> throwError . strMsg $ show name ++ " is already defined"
74+ Just _ -> throwError . errorMessage $ RedefinedIdent name
7475 Nothing -> return ()
7576
7677addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
@@ -94,7 +95,7 @@ addTypeClassDictionaries entries =
9495
9596checkDuplicateTypeArguments :: [String] -> Check ()
9697checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
97− throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
98+ throwError . errorMessage $ DuplicateTypeArgument dup
9899 where
99100 firstDup :: Maybe String
100101 firstDup = listToMaybe $ args \\ nub args
@@ -103,10 +104,10 @@ checkTypeClassInstance :: ModuleName -> Type -> Check ()
103104checkTypeClassInstance _ (TypeVar _) = return ()
104105checkTypeClassInstance _ (TypeConstructor ctor) = do
105106 env <- getEnv
106− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
107+ when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
107108 return ()
108109checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
109−checkTypeClassInstance _ ty = throwError $ mkMultipleErrors "Type class instance head is invalid." (Just (TypeError ty))
110+checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
110111
111112-- |
112113-- Check that type synonyms are fully-applied in a type
@@ -133,7 +134,7 @@ typeCheckAll mainModuleName moduleName exps = go
133134 go :: [Declaration] -> Check [Declaration]
134135 go [] = return []
135136 go (DataDeclaration dtype name args dctors : rest) = do
136− rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do
137+ rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
137138 when (dtype == Newtype) $ checkNewtype dctors
138139 checkDuplicateTypeArguments $ map fst args
139140 ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
@@ -144,10 +145,10 @@ typeCheckAll mainModuleName moduleName exps = go
144145 where
145146 checkNewtype :: [(ProperName, [Type])] -> Check ()
146147 checkNewtype [(_, [_])] = return ()
147− checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
148− checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
148+ checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
149+ checkNewtype _ = throwError . errorMessage $ InvalidNewtype
149150 go (d@(DataBindingGroupDeclaration tys) : rest) = do
150− rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do
151+ rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
151152 let syns = mapMaybe toTypeSynonym tys
152153 let dataDecls = mapMaybe toDataDecl tys
153154 (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
@@ -169,7 +170,7 @@ typeCheckAll mainModuleName moduleName exps = go
169170 toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
170171 toDataDecl _ = Nothing
171172 go (TypeSynonymDeclaration name args ty : rest) = do
172− rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do
173+ rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
173174 checkDuplicateTypeArguments $ map fst args
174175 kind <- kindsOf False moduleName name args [ty]
175176 let args' = args `withKinds` kind
@@ -178,7 +179,7 @@ typeCheckAll mainModuleName moduleName exps = go
178179 return $ TypeSynonymDeclaration name args ty : ds
179180 go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
180181 go (ValueDeclaration name nameKind [] (Right val) : rest) = do
181− d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do
182+ d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
182183 valueIsNotDefined moduleName name
183184 [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184185 addValue moduleName name ty nameKind
@@ -187,7 +188,7 @@ typeCheckAll mainModuleName moduleName exps = go
187188 return $ d : ds
188189 go (ValueDeclaration{} : _) = error "Binders were not desugared"
189190 go (BindingGroupDeclaration vals : rest) = do
190− d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do
191+ d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
191192 forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
192193 valueIsNotDefined moduleName name
193194 tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
@@ -207,19 +208,19 @@ typeCheckAll mainModuleName moduleName exps = go
207208 ds <- go rest
208209 return $ d : ds
209210 go (d@(ExternDeclaration importTy name _ ty) : rest) = do
210− rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do
211+ rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
211212 env <- getEnv
212213 kind <- kindOf moduleName ty
213− guardWith (strMsg "Expected kind *") $ kind == Star
214+ guardWith (errorMessage (ExpectedType kind)) $ kind == Star
214215 case M.lookup (moduleName, name) (names env) of
215− Just _ -> throwError . strMsg $ show name ++ " is already defined"
216+ Just _ -> throwError . errorMessage $ RedefinedIdent name
216217 Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
217218 ds <- go rest
218219 return $ d : ds
219220 go (d@(FixityDeclaration _ name) : rest) = do
220221 ds <- go rest
221222 env <- getEnv
222− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
223+ guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
223224 return $ d : ds
224225 go (d@(ImportDeclaration importedModule _ _) : rest) = do
225226 tcds <- getTypeClassDictionaries
@@ -277,7 +278,7 @@ typeCheckAll mainModuleName moduleName exps = go
277278--
278279typeCheckModule :: Maybe ModuleName -> Module -> Check Module
279280typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
280−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do
281+typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
281282 modify (\s -> s { checkCurrentModule = Just mn })
282283 decls' <- typeCheckAll mainModuleName mn exps decls
283284 forM_ exps $ \e -> do
@@ -287,63 +288,54 @@ typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do
287288 return $ Module coms mn decls' (Just exps)
288289 where
289290
290− checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
291− checkMemberExport thing extract test (ValueRef name) = do
291+ checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
292+ checkMemberExport extract dr@(ValueRef name) = do
292293 ty <- lookupVariable mn (Qualified (Just mn) name)
293− case find test (extract ty) of
294− Just hiddenType -> throwError . strMsg $
295− "Error in module '" ++ show mn ++ "':\n\
296− \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
297− Nothing -> return ()
298− checkMemberExport _ _ _ _ = return ()
294+ case filter (not . exported) (extract ty) of
295+ [] -> return ()
296+ hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
297+ where
298+ exported e = any (exports e) exps
299+ exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
300+ exports (ValueRef id1) (ValueRef id2) = id1 == id2
301+ exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
302+ exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
303+ exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
304+ exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
305+ exports _ _ = False
306+ checkMemberExport _ _ = return ()
299307
300308 -- Check that all the type constructors defined in the current module that appear in member types
301309 -- have also been exported from the module
302310 checkTypesAreExported :: DeclarationRef -> Check ()
303− checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
311+ checkTypesAreExported = checkMemberExport findTcons
304312 where
305− findTcons :: Type -> [ProperName]
313+ findTcons :: Type -> [DeclarationRef]
306314 findTcons = everythingOnTypes (++) go
307315 where
308− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
316+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]
309317 go _ = []
310− isTconHidden :: ProperName -> Bool
311− isTconHidden tyName = all go exps
312− where
313− go (TypeRef tyName' _) = tyName' /= tyName
314− go _ = True
315318
316319 -- Check that all the classes defined in the current module that appear in member types have also
317320 -- been exported from the module
318321 checkClassesAreExported :: DeclarationRef -> Check ()
319− checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
322+ checkClassesAreExported = checkMemberExport findClasses
320323 where
321− findClasses :: Type -> [ProperName]
324+ findClasses :: Type -> [DeclarationRef]
322325 findClasses = everythingOnTypes (++) go
323326 where
324− go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
327+ go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
325328 go _ = []
326329 extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
327330 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
328331 extractCurrentModuleClass _ = Nothing
329− isClassHidden :: ProperName -> Bool
330− isClassHidden clsName = all go exps
331− where
332− go (TypeClassRef clsName') = clsName' /= clsName
333− go _ = True
334332
335333 checkClassMembersAreExported :: DeclarationRef -> Check ()
336− checkClassMembersAreExported (TypeClassRef name) = do
334+ checkClassMembersAreExported dr@(TypeClassRef name) = do
337335 let members = ValueRef `map` head (mapMaybe findClassMembers decls)
338336 let missingMembers = members \\ exps
339− unless (null missingMembers) $
340− throwError . strMsg $
341− "Error in module '" ++ show mn ++ "':\n\
342− \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
337+ unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
343338 where
344− runValueRef :: DeclarationRef -> Ident
345− runValueRef (ValueRef refName) = refName
346− runValueRef _ = error "non-ValueRef passed to runValueRef"
347339 findClassMembers :: Declaration -> Maybe [Ident]
348340 findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
349341 findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d