[properly check for duplicate instances
John Meacham <john@repetae.net>**20120205015651
 Ignore-this: 720d6018d440148d5556cca2c42d1bb6
] hunk ./src/FrontEnd/Class.hs 11
+    checkForDuplicateInstaces,
hunk ./src/FrontEnd/Class.hs 35
+import Text.Printf
+import qualified Data.List
hunk ./src/FrontEnd/Class.hs 49
+import FrontEnd.Warning
hunk ./src/FrontEnd/Class.hs 142
-        CH (Map.union a c) (Map.unionWith (++) b d)
+        CH (Map.union a c) (Map.unionWith Data.List.union b d)
hunk ./src/FrontEnd/Class.hs 216
-addOneInstanceToHierarchy :: ClassHierarchy -> Inst -> ClassHierarchy
-addOneInstanceToHierarchy (CH r i) inst@Inst { instHead = cntxt :=> IsIn className _ } =
-    CH r (Map.insertWith (++) className [inst] i)
-
+-- this does not check for duplicates, use checkForDuplicateInstaces after all
+-- instances have been added to do so.
hunk ./src/FrontEnd/Class.hs 220
-    CH r (Map.insertWith cd className [inst] i) where
-        cd [inst] cs = runIdentity $ ensureNotDup (instSrcLoc inst) inst cs
+    CH r (Map.insertWith Data.List.union className [inst] i)
hunk ./src/FrontEnd/Class.hs 418
-makeClassHierarchy :: ClassHierarchy -> KindEnv -> [HsDecl] -> ClassHierarchy
-makeClassHierarchy (CH ch _is) kt ds = ans where
-    ans =  execWriter (mapM_ f ds) -- Map.fromListWith combineClassRecords [  (className x,x)| x <- execWriter (mapM_ f ds) ]
+makeClassHierarchy :: MonadWarn m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy
+makeClassHierarchy (CH ch _is) kt ds = mconcat `liftM` mapM f ds where
hunk ./src/FrontEnd/Class.hs 422
-                newClassContext = [HsAsst className [argName]] -- hsContextToContext [(className, argName)]                                                                                                                                                                   -- TODO
+                newClassContext = [HsAsst className args]
hunk ./src/FrontEnd/Class.hs 424
-                [Just argName] = map fromHsTyVar (hsClassHeadArgs chead)
-            tell $ classHierarchyFromRecords [ClassRecord {
+                args = [ a | ~(Just a) <- map fromHsTyVar (hsClassHeadArgs chead) ]
+            return $ classHierarchyFromRecords [ClassRecord {
hunk ./src/FrontEnd/Class.hs 431
-                classSupers = [ toName ClassName x | HsAsst x _ <- cntxt],
-                --classInsts = [ emptyInstance { instHead = i } | i@(_ :=> IsIn n _) <- [], nameName n == className],
+                classSupers = [ toName ClassName x | ~(HsAsst x _) <- cntxt],
hunk ./src/FrontEnd/Class.hs 435
-        --HsQualType cntxt tbody = t
hunk ./src/FrontEnd/Class.hs 449
-        --crs <- flip mapM [ (cn,i) | i@Inst { instHead = _ :=> IsIn cn _} <- insts] $ \ (x,inst) -> case Map.lookup x ch of
-        --    Just cr -> ensureNotDup (srcLoc decl) inst (classInsts cr) >> return [cr { classInsts = mempty }]
-        --    Nothing -> return [] -- case Map.lookup x ans of
-                -- Just _ -> return []
-               --  Nothing -> return [] -- failSl (srcLoc decl) "Invalid Instance"
-        tell $ foldl addOneInstanceToHierarchy mempty insts
-    f _ = return ()
+        return $ foldl (flip addInstanceToHierarchy) mempty insts
+    f _ = return mempty
+
+checkForDuplicateInstaces :: MonadWarn m
+    => ClassHierarchy    -- ^ imported class hierarchy
+    -> ClassHierarchy    -- ^ locally defined hierarchy
+    -> m ClassHierarchy  -- ^ possibly simplified local hierarchy
+checkForDuplicateInstaces iCh (CH ch is) = mapM_ f (Map.toList is) >> return (CH ch is) where
+    f (className,is) = do
+        let is' = findClassInsts iCh className ++ is
+            sgu = sortGroupUnderFG fst snd [ ((cn,getTypeHead tt), i) |
+                i@Inst { instSrcLoc = sl, instHead = _ :=> IsIn cn tt } <- is' ]
+        mapM_ g sgu
+    g (_,[_]) = return ()
+    g (_,sls) | all instDerived sls = return ()
+    g ((ch,th),sls) = warn (instSrcLoc $ head sls) DuplicateInstances $
+        printf "instance (%s (%s ..)) defined multiple times: %s"
+            (show ch) (show th) (show $ map instSrcLoc sls)
hunk ./src/FrontEnd/DataConsAssump.hs 39
-dataConsEnv :: Module -> KindEnv -> [HsDecl] -> Map.Map Name Sigma
-dataConsEnv modName kt decls
-   = Map.unions $ map (dataDeclEnv modName kt) decls
+{-# NOINLINE dataConsEnv #-}
+dataConsEnv :: KindEnv -> [HsDecl] -> Map.Map Name Sigma
+dataConsEnv kt decls
+   = Map.unions $ map (dataDeclEnv (error "dataConsenvModName") kt) decls
hunk ./src/FrontEnd/KindInfer.hs 390
+    consLike (HsTyFun a b) = varLike a && varLike b
+    consLike (HsTyTuple ts) = all varLike ts
+    consLike t = case fromHsTypeApp t of
+        (HsTyCon {},as) -> all varLike as
+        _ -> False
hunk ./src/FrontEnd/KindInfer.hs 438
-    f (HsInstDecl _ HsClassHead { .. } sigsAndDefaults) = do
-        let consLike (HsTyFun a b) = varLike a && varLike b
-            consLike (HsTyTuple ts) = all varLike ts
-            consLike t = case fromHsTypeApp t of
-                (HsTyCon {},as) -> all varLike as
-                _ -> False
+    f HsDeclDeriving { hsDeclClassHead = ch } = checkInstance ch
+    f HsInstDecl { hsDeclClassHead = ch } = checkInstance ch
+    f _ = return ()
+    checkInstance HsClassHead { .. } = do
hunk ./src/FrontEnd/KindInfer.hs 450
-    f _ = return ()
hunk ./src/FrontEnd/Tc/Module.hs 68
-{-
-buildFieldMap :: Ho -> [ModInfo] -> FieldMap
-buildFieldMap ho ms = (ans',ans) where
-        theDefs = [ (x,z) | (x,_,z) <- concat $ map modInfoDefs ms, nameType x == DataConstructor ]
-        allDefs = theDefs ++ [ (x,z) | (x,(_,z)) <- Map.toList (hoDefs $ hoExp ho), nameType x == DataConstructor ]
-        ans = Map.fromList $ sortGroupUnderFG fst snd $ concat [ [ (y,(x,i)) |  y <- ys | i <- [0..] ]  | (x,ys) <-  allDefs ]
-        ans' = Map.fromList $ concatMap modInfoConsArity ms ++ getConstructorArities (hoDataTable $ hoBuild ho)
--}
-
hunk ./src/FrontEnd/Tc/Module.hs 76
-    zmod' <-  driftDerive (modInfoHsModule m)
+    zmod' <- driftDerive (modInfoHsModule m)
hunk ./src/FrontEnd/Tc/Module.hs 97
-dtDataDesc :: Monad m => DataTable -> Name -> m DatDesc
-dtDataDesc dt n = maybe (fail "dtDataDesc") return $ do
-    c <- getConstructor n dt
-    let datEnum = conVirtual c >>= return . DatEnum
-        datNewT = do ErasedAlias <- return $ conAlias c; DataNormal [n] <- return $ conChildren c; return $ DatNewT n
-        datMany = do DataNormal ns <- return $ conChildren c ; return $ DatMany [ (n,-1) | n <- ns ]
-    datEnum `mplus` datNewT `mplus` datMany
-
hunk ./src/FrontEnd/Tc/Module.hs 119
---    putStrLn "Synonyms"
---    putStrLn $ HsPretty.render $ showSynonyms pprint thisTypeSynonyms
hunk ./src/FrontEnd/Tc/Module.hs 120
-    -- 'expandTypeSyns' is in the Warning monad and doesn't require IO.
-    let f x = expandTypeSyns ts (modInfoHsModule x) >>= return . FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)
+    let f x = expandTypeSyns ts (modInfoHsModule x) >>=
+            return . FrontEnd.Infix.infixHsModule fixityMap >>=
+            \z -> return (modInfoHsModule_s ( z) x)
hunk ./src/FrontEnd/Tc/Module.hs 132
-    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl, isHsClassAliasDecl]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls
+    let classAndDataDecls = filter (or' [isHsDataDecl, isHsNewTypeDecl, isHsClassDecl, isHsClassAliasDecl]) ds
hunk ./src/FrontEnd/Tc/Module.hs 140
-    -- collect types for data constructors
-
-    let localDConsEnv =  dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
hunk ./src/FrontEnd/Tc/Module.hs 141
+    let localDConsEnv = dataConsEnv kindInfo classAndDataDecls
hunk ./src/FrontEnd/Tc/Module.hs 144
-        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |  (n,s) <- Map.toList localDConsEnv]
+        mapM_ putStrLn [ show n ++  " :: " ++ prettyPrintType s |
+            (n,s) <- Map.toList localDConsEnv]
hunk ./src/FrontEnd/Tc/Module.hs 147
-    --let globalDConsEnv = localDConsEnv `Map.union` importDConsEnv
+    cHierarchy <- makeClassHierarchy importClassHierarchy kindInfo ds
+    let smallClassHierarchy = foldr addInstanceToHierarchy cHierarchy dinsts where
+            derivingClauses = collectDeriving ds
+            dataInfo = Map.fromList $ concatMap getDataDesc ds
+            dinsts = concatMap g derivingClauses where
+                g r@(_,c,t) | c `elem` enumDerivableClasses,
+                    Just (DatEnum (_:_:_)) <- Map.lookup t dataInfo = [f r]
+                            | c `elem` enumDerivableClasses,
+                    t `elem` [tc_Bool, tc_Ordering, tc_IOErrorType, tc_IOMode] = [f r]
+                --g r@(_,c,t) | c `notElem` noNewtypeDerivable, Just (DatMany True [_]) <- Map.lookup t dataInfo = [f r]
+                g _ = []
+                f (sl,c,t) = emptyInstance { instSrcLoc = sl, instDerived = True, instHead = [] :=> IsIn c (TCon (Tycon t kindStar)) }
+    smallClassHierarchy <- checkForDuplicateInstaces importClassHierarchy smallClassHierarchy
hunk ./src/FrontEnd/Tc/Module.hs 161
-    let smallClassHierarchy = foldr addInstanceToHierarchy (makeClassHierarchy importClassHierarchy kindInfo ds) dinsts
-        cHierarchyWithInstances = scatterAliasInstances $ smallClassHierarchy `mappend` importClassHierarchy
-        derivingClauses = collectDeriving ds
-        dataInfo = Map.fromList $ concatMap getDataDesc ds
-        --dataTable = hoDataTable htc
-        dinsts = concatMap g derivingClauses where
-            g r@(_,c,t) | c `elem` enumDerivableClasses, Just (DatEnum (_:_:_)) <- Map.lookup t dataInfo = [f r]
-                        | c `elem` enumDerivableClasses, t `elem` [tc_Bool, tc_Ordering, tc_IOErrorType, tc_IOMode] = [f r]
-            --g r@(_,c,t) | c `notElem` noNewtypeDerivable, Just (DatMany True [_]) <- Map.lookup t dataInfo = [f r]
-            g _ = []
-            f (sl,c,t) = emptyInstance { instSrcLoc = sl, instDerived = True, instHead = [] :=> IsIn c (TCon (Tycon t kindStar)) }
+    let cHierarchyWithInstances = scatterAliasInstances $
+            smallClassHierarchy `mappend` importClassHierarchy
hunk ./src/FrontEnd/Tc/Module.hs 167
-
hunk ./src/FrontEnd/Tc/Module.hs 170
-
hunk ./src/FrontEnd/Tc/Module.hs 279
+    processIOErrors
hunk ./src/FrontEnd/Warning.hs 85
+    | DuplicateInstances
hunk ./src/FrontEnd/Warning.hs 107
+    f DuplicateInstances {} = True