[turn WarnType into a real algebraic data type.
John Meacham <john@repetae.net>**20120203041757
 Ignore-this: 8f057ac3d1bdeb2aa4c30277beeaff0d
] hunk ./src/E/PrimDecode.hs 163
-        warn srcLoc "primitive-unxnown" $
+        warn srcLoc (PrimitiveUnknown pName) $
hunk ./src/E/PrimDecode.hs 184
-                warn srcLoc "primitive-badtype" $
+                warn srcLoc PrimitiveBadType $
hunk ./src/FrontEnd/Class.hs 8
+    ClassType(..),
hunk ./src/FrontEnd/Class.hs 80
--- | a class record is either a class along with instances, or just instances.
--- you can tellthe difference by the presence of the classArgs field
-
-data ClassType
-    = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias
+data ClassType = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias
hunk ./src/FrontEnd/Class.hs 84
-data AssociatedType = Assoc Tycon !Bool [Tyvar] Kind
+data AssociatedType = Assoc !Tycon !Bool [Tyvar] Kind
hunk ./src/FrontEnd/Class.hs 89
-    className    :: Class, -- ^ can be a TypeConstructor if we are a type or data family
-    classSrcLoc  :: SrcLoc,
+    className    :: !Class, -- ^ can be a TypeConstructor if we are a type or data family
+    classSrcLoc  :: !SrcLoc,
hunk ./src/FrontEnd/Diagnostic.hs 17
-       Diagnostic(..), dumpDiagnostic,
+       Diagnostic(..),
hunk ./src/FrontEnd/Diagnostic.hs 22
+       dumpDiagnostic,
hunk ./src/FrontEnd/Diagnostic.hs 36
-        | BogusError
hunk ./src/FrontEnd/Diagnostic.hs 48
-           BogusError    -> ("bogus reason", "bogus reason")
hunk ./src/FrontEnd/Exports.hs 92
-        f (x,ys) = warn bogusASrcLoc "ambiguous-export" ("module " <> fromModule (modInfoName m) <> " has ambiguous exports: " ++ show ys) >> return (head ys)
+        f (x,ys) = warn bogusASrcLoc (AmbiguousExport (modInfoName m) ys) ("module " <> fromModule (modInfoName m) <> " has ambiguous exports: " ++ show ys) >> return (head ys)
hunk ./src/FrontEnd/HsErrors.hs 10
+
hunk ./src/FrontEnd/HsErrors.hs 20
-hsType x@HsTyForall {} = do
-    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
-    hsQualType (hsTypeType x)
-hsType x@HsTyExists {} = do
-    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
-    hsQualType (hsTypeType x)
+--hsType x@HsTyForall {} = do
+--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
+--    hsQualType (hsTypeType x)
+--hsType x@HsTyExists {} = do
+--    addWarn "h98-forall" "Explicit quantification is a non-haskell98 feature"
+--    hsQualType (hsTypeType x)
hunk ./src/FrontEnd/HsErrors.hs 47
-        when (null cs) $ warn sl "h98-emptydata" "data types with no constructors are a non-haskell98 feature"
+--        when (null cs) $ warn sl "h98-emptydata" "data types with no constructors are a non-haskell98 feature"
hunk ./src/FrontEnd/HsErrors.hs 50
-        when (not isEnum && class_Enum `elem` ds) $ warn sl "derive-enum" "Cannot derive enum from non enumeration type"
-        when (not isEnum && length cs /= 1 && class_Bounded `elem` ds) $ warn sl "derive-bounded" "Cannot derive bounded from non enumeration or unary type"
+--        when (not isEnum && class_Enum `elem` ds) $ warn sl "derive-enum" "Cannot derive enum from non enumeration type"
+--        when (not isEnum && length cs /= 1 && class_Bounded `elem` ds) $ warn sl "derive-bounded" "Cannot derive bounded from non enumeration or unary type"
hunk ./src/FrontEnd/HsErrors.hs 57
-    f context@TopLevel decl@HsTypeDecl { hsDeclTArgs = as } | any (not . isHsTyVar) as = warn (srcLoc decl) "invalid-decl" $ "complex type arguments not allowed " ++ show context
+    f context@TopLevel decl@HsTypeDecl { hsDeclTArgs = as } | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
hunk ./src/FrontEnd/HsErrors.hs 59
-        | any (not . isHsTyVar) as = warn (srcLoc decl) "invalid-decl" $ "complex type arguments not allowed " ++ show context
+        | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
hunk ./src/FrontEnd/HsErrors.hs 63
-        | any (not . isHsTyVar) (drop (length ts) as) = warn (srcLoc decl) "invalid-decl" $ "extra complex type arguments not allowed " ++ show context
-    f context decl@HsDataDecl {} = warn (srcLoc decl) "invalid-decl" $ "data declaration not allowed " ++ show context
-    f context decl@HsNewTypeDecl {} = warn (srcLoc decl) "invalid-decl" $ "newtype declaration not allowed " ++ show context
+        | any (not . isHsTyVar) (drop (length ts) as) = warn (srcLoc decl) InvalidDecl $ "extra complex type arguments not allowed " ++ show context
+    f context decl@HsDataDecl {} = warn (srcLoc decl) InvalidDecl $ "data declaration not allowed " ++ show context
+    f context decl@HsNewTypeDecl {} = warn (srcLoc decl) InvalidDecl $ "newtype declaration not allowed " ++ show context
hunk ./src/FrontEnd/HsErrors.hs 68
-    f context decl@HsClassDecl {} = warn (srcLoc decl) "invalid-decl" $ "class declaration not allowed " ++ show context
-    f context decl@HsInstDecl {} = warn (srcLoc decl) "invalid-decl" $ "instance declaration not allowed " ++ show context
+    f context decl@HsClassDecl {} = warn (srcLoc decl) InvalidDecl $ "class declaration not allowed " ++ show context
+    f context decl@HsInstDecl {} = warn (srcLoc decl) InvalidDecl $ "instance declaration not allowed " ++ show context
hunk ./src/FrontEnd/HsErrors.hs 74
-fetchQtArgs sl _ = warn sl "invalid-decl" "invalid head in class or instance decl" >> return []
+fetchQtArgs sl _ = warn sl InvalidDecl "invalid head in class or instance decl" >> return []
hunk ./src/FrontEnd/HsErrors.hs 77
-checkDeriving sl True _ = warn sl "h98-newtypederiv" "arbitrary newtype derivations are a non-haskell98 feature"
+--checkDeriving sl True _ = warn sl "h98-newtypederiv" "arbitrary newtype derivations are a non-haskell98 feature"
hunk ./src/FrontEnd/HsErrors.hs 80
-    in warn sl "unknown-deriving" ("attempt to derive from a non-derivable class: " ++ unwords (map show nonDerivable))
+    in warn sl (UnknownDeriving nonDerivable) ("attempt to derive from a non-derivable class: " ++ unwords (map show nonDerivable))
hunk ./src/FrontEnd/KindInfer.hs 1
+{-# OPTIONS -funbox-strict-fields #-}
hunk ./src/FrontEnd/KindInfer.hs 30
+import qualified Data.Set as Set
hunk ./src/FrontEnd/KindInfer.hs 68
-instance FreeVars Kind [Kindvar] where
-   freeVars (KVar kindvar) = [kindvar]
-   freeVars (kind1 `Kfun` kind2) = freeVars kind1 `union` freeVars kind2
-   freeVars KBase {} = []
+instance FreeVars Kind (Set.Set Kindvar) where
+   freeVars (KVar kindvar) = Set.singleton kindvar
+   freeVars (kind1 `Kfun` kind2) = freeVars kind1 `Set.union` freeVars kind2
+   freeVars KBase {} = mempty
hunk ./src/FrontEnd/KindInfer.hs 89
-    kiEnv :: IORef KindEnv,
-    kiWhere :: KiWhere,
-    kiVarnum :: IORef Int
+    kiEnv     :: !(IORef KindEnv),
+    kiWhere   :: !KiWhere,
+    kiVarnum  :: !(IORef Int)
hunk ./src/FrontEnd/KindInfer.hs 153
-    when (u `elem` freeVars k) $ fail $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k
+    when (u `Set.member` freeVars k) $ fail $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k
hunk ./src/FrontEnd/KindInfer.hs 250
-    let defs = snub (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses))
+    let defs = Set.toList (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses))
hunk ./src/FrontEnd/KindInfer.hs 367
+kiDecl HsTypeFamilyDecl { .. } = do
+    kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName)
+    kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind)
hunk ./src/FrontEnd/KindInfer.hs 533
-    f (TForAll vs (ps :=> t))
+    f (TForAll vs (ps :=> (f -> nt)))
hunk ./src/FrontEnd/KindInfer.hs 536
-        where
-        nt = f t
-    f (TExists vs (ps :=> t))
+    f (TExists vs (ps :=> (f -> nt)))
hunk ./src/FrontEnd/KindInfer.hs 539
-        where
-        nt = f t
-    f (TArrow a b)
+    f (TArrow (f -> na) (f -> nb))
hunk ./src/FrontEnd/KindInfer.hs 543
-        where
-        na = f a
-        nb = f b
hunk ./src/FrontEnd/Lexer.hs 269
-                    addWarn "unknown-pragma" $ "The pragma '" ++ pname ++ "' is unknown"
+                    addWarn (UnknownPragma $ packString pname) $ "The pragma '" ++ pname ++ "' is unknown"
hunk ./src/FrontEnd/Rename.hs 81
-        mult xs@(~((n,sl):_)) = warn sl "multiply-defined" (show n ++ " is defined multiple times: " ++ show xs)
+        mult xs@(~((n,sl):_)) = warn sl (MultiplyDefined n (snds xs)) (show n ++ " is defined multiple times: " ++ show xs)
hunk ./src/FrontEnd/Rename.hs 152
-            warn sl "undefined-name" ("unknown name in export list: " ++ show n)
+            warn sl (UndefinedName n) ("unknown name in export list: " ++ show n)
hunk ./src/FrontEnd/Rename.hs 694
-            warn sl "undefined-name" err
+            warn sl (UndefinedName hsName) err
hunk ./src/FrontEnd/Rename.hs 699
-            warn sl "undefined-name" err
+            warn sl (UndefinedName hsName) err
hunk ./src/FrontEnd/Representation.hs 167
-type Class = Name
-
hunk ./src/FrontEnd/SrcLoc.hs 13
-data SrcLoc = SrcLoc { srcLocFileName :: PackedString, srcLocLine :: {-# UNPACK #-} !Int, srcLocColumn :: {-# UNPACK #-}  !Int}
+data SrcLoc = SrcLoc {
+        srcLocFileName :: PackedString,
+        srcLocLine :: {-# UNPACK #-} !Int,
+        srcLocColumn :: {-# UNPACK #-} !Int
+        }
hunk ./src/FrontEnd/SrcLoc.hs 25
-bogusASrcLoc = SrcLoc (packString "bogus#") (-1) (-1)
+-- Useful bogus file names used to indicate where non file based errors are.
+fileNameCommandLine = packString "(command line)"
+fileNameUnknown = packString "(unknown)"
+fileNameGenerated = packString "(generated)"
+
+bogusASrcLoc = SrcLoc fileNameUnknown (-1) (-1)
hunk ./src/FrontEnd/Tc/Class.hs 159
-        addWarn "type-defaults" msg
+        --addWarn "type-defaults" msg
hunk ./src/FrontEnd/Tc/Monad.hs 121
-    tcInfoEnv :: TypeEnv, -- initial typeenv, data constructors, and previously infered types
-    tcInfoSigEnv :: TypeEnv, -- type signatures used for binding analysis
-    tcInfoModName :: Module,
-    tcInfoKindInfo :: KindEnv,
+    tcInfoEnv            :: TypeEnv, -- initial typeenv, data constructors, and previously infered types
+    tcInfoSigEnv         :: TypeEnv, -- type signatures used for binding analysis
+    tcInfoModName        :: Module,
+    tcInfoKindInfo       :: KindEnv,
hunk ./src/FrontEnd/TypeSynonyms.hs 64
-            warn (head [ sl | (_,(_,_,sl)) <- ns]) "type-synonym-recursive" ("Recursive type synonyms:" <+> show (fsts ns))
+            warn (head [ sl | (_,(_,_,sl)) <- ns]) TypeSynonymRecursive ("Recursive type synonyms:" <+> show (fsts ns))
hunk ./src/FrontEnd/TypeSynonyms.hs 92
-            lift $ warn sl "type-synonym-partialap" ("Partially applied typesym:" <+> show n <+> "need" <+> show (- excess) <+> "more arguments.")
+            lift $ warn sl TypeSynonymPartialAp ("Partially applied typesym:" <+> show n <+> "need" <+> show (- excess) <+> "more arguments.")
hunk ./src/FrontEnd/Warning.hs 4
+    WarnType(..),
hunk ./src/FrontEnd/Warning.hs 7
-    warnF,
hunk ./src/FrontEnd/Warning.hs 8
-    addDiag,
hunk ./src/FrontEnd/Warning.hs 9
+    -- IO monad
hunk ./src/FrontEnd/Warning.hs 17
-import Data.List
hunk ./src/FrontEnd/Warning.hs 20
+import Name.Name
hunk ./src/FrontEnd/Warning.hs 23
+import StringTable.Atom
hunk ./src/FrontEnd/Warning.hs 26
-{-# NOINLINE ioWarnings #-}
-ioWarnings :: IORef [Warning]
-ioWarnings = unsafePerformIO $ newIORef []
-
hunk ./src/FrontEnd/Warning.hs 27
-    warnSrcLoc :: !SrcLoc,
-    warnType :: String,
+    warnSrcLoc  :: !SrcLoc,
+    warnType    :: WarnType,
hunk ./src/FrontEnd/Warning.hs 36
--- If in the IO monad, just show the warning
-instance MonadWarn IO where
-    addWarning w = modifyIORef ioWarnings (w:)
-
-instance MonadWarn (Writer [Warning]) where
-    addWarning w = tell [w]
-instance MonadWarn Identity where
-    addWarning w = fail $ show w
-
+addWarn :: (MonadWarn m, MonadSrcLoc m) => WarnType -> String -> m ()
hunk ./src/FrontEnd/Warning.hs 41
-addDiag s = warn bogusASrcLoc "diagnostic" s
+warn :: MonadWarn m => SrcLoc -> WarnType -> String -> m ()
hunk ./src/FrontEnd/Warning.hs 44
+
+err :: MonadWarn m => WarnType -> String -> m ()
hunk ./src/FrontEnd/Warning.hs 47
-warnF fn t m  = warn bogusASrcLoc { srcLocFileName = fn } t m
hunk ./src/FrontEnd/Warning.hs 70
-processErrors' doDie ws = mapM_ s ws' >> when (die && doDie) exitFailure >> return die where
-    ws' = filter ((`notElem` ignore) . warnType ) $ snub ws
+processErrors' doDie ws = mapM_ s (snub ws) >> when (die && doDie) exitFailure >> return die where
+--    ws' = filter ((`notElem` ignore) . warnType ) $ snub ws
hunk ./src/FrontEnd/Warning.hs 78
-    die = (not $ null $ intersect (map warnType ws') fatal) && not (optKeepGoing options)
+    die = (any warnIsFatal (map warnType ws)) && not (optKeepGoing options)
hunk ./src/FrontEnd/Warning.hs 80
---data WarnType
---    = UndefinedName Name
---    | AmbiguousName Name
---    | MultiplyDefined Name
---    | UnknownImport Module
---    | ParseError
+data WarnType
+    = AmbiguousExport Module [Name]
+    | AmbiguousName Name [Name]
+    | InvalidDecl
+    | MissingDep String
+    | MissingModule Module
+    | MultiplyDefined Name [SrcLoc]
+    | OccursCheck
+    | PrimitiveBadType
+    | PrimitiveUnknown Atom
+    | TypeSynonymPartialAp
+    | TypeSynonymRecursive
+    | UndefinedName Name
+    | UnificationError
+    | UnknownDeriving [Class]
+    | UnknownOption
+    | UnknownPragma PackedString
+    deriving(Eq,Ord)
hunk ./src/FrontEnd/Warning.hs 99
-fatal = [
-    "undefined-name",
-    "ambiguous-name",
-    "multiply-defined",
-    "ambiguous-export",
-    "unknown-import",
-    "parse-error",
-    "missing-dep",
-    "invalid-decl",
-    "invalid-assoc",
-    "invalid-primitive",
-    "type-synonym-recursive",
-    "type-synonym-partialap" ]
-
-ignore = ["h98-emptydata", "h98-forall"]
+warnIsFatal w = f w where
+    f AmbiguousExport {} = True
+    f AmbiguousName {} = True
+    f InvalidDecl {} = True
+    f MissingDep {} = True
+    f MissingModule {} = True
+    f MultiplyDefined {} = True
+    f OccursCheck {} = True
+    f TypeSynonymPartialAp {} = True
+    f TypeSynonymRecursive {} = True
+    f UndefinedName {} = True
+    f UnificationError {} = True
+    f UnknownDeriving {} = True
+    f UnknownOption {} = True
+    f _ = False
hunk ./src/FrontEnd/Warning.hs 121
-msg "diagnostic" m = "Diagnostic: " ++ m
-msg t m = (if t `elem` fatal then "Error: " else "Warning: ") ++ m
+msg t m = (if warnIsFatal t then "Error: " else "Warning: ") ++ m
hunk ./src/FrontEnd/Warning.hs 140
+
+----------------
+-- Warning monad
+----------------
+
+{-# NOINLINE ioWarnings #-}
+ioWarnings :: IORef [Warning]
+ioWarnings = unsafePerformIO $ newIORef []
+
+instance MonadWarn IO where
+    addWarning w = modifyIORef ioWarnings (w:)
+instance MonadWarn (Writer [Warning]) where
+    addWarning w = tell [w]
+instance MonadWarn Identity
hunk ./src/Ho/Build.hs 49
-import FrontEnd.Warning
+import FrontEnd.Warning(err,processIOErrors,WarnType(..))
hunk ./src/Ho/Build.hs 99
-findFirstFile err [] = FrontEnd.Warning.err "missing-dep" ("Module not found: " ++ err) >> fail ("Module not found: " ++ err) -- return (error "findFirstFile not found","",undefined)
-findFirstFile err ((x,a):xs) = flip catch (\e ->   findFirstFile err xs) $ do
+findFirstFile err [] = FrontEnd.Warning.err (MissingDep err) ("Module not found: " ++ err) >> fail ("Module not found: " ++ err)
+findFirstFile err ((x,a):xs) = flip catch (\e -> findFirstFile err xs) $ do
hunk ./src/Ho/ReadSource.hs 124
-        warn (bogusASrcLoc { srcLocFileName = packString fn }) "unknown-option" "Unknown OPTIONS pragma"
+        warn (bogusASrcLoc { srcLocFileName = packString fn })
+            UnknownOption "Invalid options in OPTIONS pragma"
hunk ./src/Name/Name.hs 5
+    Class,
hunk ./src/Name/Name.hs 212
+-- useful synonym
+type Class = Name
+