@@ -27,7 +27,7 @@ import Language.PureScript.TypeChecker.Types as T
2727import Language.PureScript.TypeChecker.Synonyms as T
2828
2929import Data.Maybe
30−import Data.List (nub, (\\))
30+import Data.List (nub, (\\), sort, group)
3131import Data.Foldable (for_)
3232
3333import qualified Data.Map as M
@@ -216,8 +216,14 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
216216 go (d@(TypeClassDeclaration pn args implies tys)) = do
217217 addTypeClass moduleName pn args implies tys
218218 return d
219− go (d@(TypeInstanceDeclaration dictName deps className tys _)) =
220− goInstance d dictName deps className tys
219+ go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do
220+ mapM_ (checkTypeClassInstance moduleName) tys
221+ forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
222+ checkOrphanInstance dictName className tys
223+ _ <- traverseTypeInstanceBody checkInstanceMembers body
224+ let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
225+ addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
226+ return d
221227 go (PositionedDeclaration pos com d) =
222228 warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d
223229
@@ -229,29 +235,36 @@ typeCheckAll moduleName _ ds = mapM go ds <* mapM_ checkOrphanFixities ds
229235 warnAndRethrowWithPosition pos $ checkOrphanFixities d
230236 checkOrphanFixities _ = return ()
231237
232− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> Check Declaration
233− goInstance d dictName deps className tys = do
234− mapM_ (checkTypeClassInstance moduleName) tys
235− forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
236− checkOrphanInstance moduleName className tys
237− let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)
238− addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdName dict) dict
239− return d
240−
238+ checkInstanceMembers :: [Declaration] -> Check [Declaration]
239+ checkInstanceMembers instDecls = do
240+ let idents = sort . map head . group . map memberName $ instDecls
241+ for_ (firstDuplicate idents) $ \ident ->
242+ throwError . errorMessage $ DuplicateValueDeclaration ident
243+ return instDecls
241244 where
245+ memberName :: Declaration -> Ident
246+ memberName (ValueDeclaration ident _ _ _) = ident
247+ memberName (PositionedDeclaration _ _ d) = memberName d
248+ memberName _ = error "checkInstanceMembers: Invalid declaration in type instance definition"
242249
243− checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
244− checkOrphanInstance mn (Qualified (Just mn') _) tys'
245− | mn == mn' || any checkType tys' = return ()
246− | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
247− where
248− checkType :: Type -> Bool
249− checkType (TypeVar _) = False
250− checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn''
251− checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
252− checkType (TypeApp t1 _) = checkType t1
253− checkType _ = error "Invalid type in instance in checkOrphanInstance"
254− checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
250+ firstDuplicate :: (Eq a) => [a] -> Maybe a
251+ firstDuplicate (x : xs@(y : _))
252+ | x == y = Just x
253+ | otherwise = firstDuplicate xs
254+ firstDuplicate _ = Nothing
255+
256+ checkOrphanInstance :: Ident -> Qualified ProperName -> [Type] -> Check ()
257+ checkOrphanInstance dictName className@(Qualified (Just mn') _) tys'
258+ | moduleName == mn' || any checkType tys' = return ()
259+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys'
260+ where
261+ checkType :: Type -> Bool
262+ checkType (TypeVar _) = False
263+ checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn''
264+ checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
265+ checkType (TypeApp t1 _) = checkType t1
266+ checkType _ = error "Invalid type in instance in checkOrphanInstance"
267+ checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
255268
256269 -- |
257270 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,