[switch kind inference to use the unified warnings mechanism, switch class declarations to use a HsClassHead 
John Meacham <john@repetae.net>**20120204220732
 Ignore-this: 33fc7a51ab745a8bf3ddca33fccb0a97
] hunk ./Makefile.am 272
-	find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[[:space:]]*$$//'
-	find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[[:space:]]*$$//'
+#	#find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[[:space:]]*$$//'
+#	#find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[[:space:]]*$$//'
+	find src -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[ 	]*$$//'
+	find lib -not \( -name .svn -prune -o -name .git -prune \) -type f -print0 | xargs -0 sed -i  -E 's/[ 	]*$$//'
hunk ./regress/regress.prl 60
-
hunk ./regress/regress.prl 92
-
hunk ./regress/regress.prl 101
-
hunk ./regress/regress.prl 114
-
-
hunk ./regress/regress.prl 204
-    my @cmd = (@jhc, ($verbose ? ('-v') : ()), ($opt_win ? ('-mwin32') : ()), @libs , @fast, '-o', "$rd/$name", @flags, @opts, "$cwd/$fn");
+    my @cmd = (@jhc,"$cwd/$fn", ($verbose ? ('-v') : ()), ($opt_win ? ('-mwin32') : ()), @libs , @fast, '-o', "$rd/$name", @flags, @opts);
hunk ./regress/regress.prl 305
-
hunk ./regress/regress.prl 341
-
hunk ./regress/tests/0_parse/2_pass/ghc/config.yaml 6
-    read042:
-        skip: BangPatterns
hunk ./regress/tests/0_parse/config.yaml 1
-jhc_flags: --stop parse --stale Main
+jhc_flags: --stop parse --stale Main --no-ho
hunk ./regress/tests/1_typecheck/4_fail/config.yaml 2
+tests:
+   T3468:
+     skip: no SOURCE pragma
+   T3966:
+     skip: no UNPACK pragma
+   Tcfail186_Help:
+     skip: not test
hunk ./src/E/FromHs.hs 740
-    cClassDecl (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = do
+    cClassDecl (HsClassDecl _ chead decls) = do
hunk ./src/E/FromHs.hs 743
-            className = (toName ClassName name)
+            className = hsClassHead chead
hunk ./src/FrontEnd/Class.hs 248
+chToClassHead :: KindEnv -> HsClassHead -> ([Pred],(Name,[Type]))
+chToClassHead kt qt@HsClassHead { .. }  =
+    vtrace ("qtToClassHead" <+> show qt) $
+    let res = (map (hsAsstToPred kt) hsClassHeadContext,(hsClassHead,
+            map (runIdentity . hsTypeToType (kiHsQualType kt (HsQualType hsClassHeadContext (HsTyTuple [])))) hsClassHeadArgs))
+    in vtrace ("=" <+> show res) res
+
hunk ./src/FrontEnd/Class.hs 282
-instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ qualType methods)
-   = unzip $ map (defaultMethodToTopDecls kt methodSigs qualType) $ methodGroups where
-   HsQualType _ (HsTyApp (HsTyCon className) _) = qualType
+instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ chead methods)
+   = unzip $ map (defaultMethodToTopDecls kt methodSigs chead) $ methodGroups where
+   className = hsClassHead chead
+   --HsQualType _ (HsTyApp (HsTyCon className) _) = qualType
hunk ./src/FrontEnd/Class.hs 331
-defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsQualType -> (Name, HsDecl) -> (HsDecl,Assump)
+defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsClassHead -> (Name, HsDecl) -> (HsDecl,Assump)
hunk ./src/FrontEnd/Class.hs 333
-defaultMethodToTopDecls kt methodSigs (HsQualType cntxt classApp) (methodName, methodDecls)
+defaultMethodToTopDecls kt methodSigs HsClassHead { .. } (methodName, methodDecls)
hunk ./src/FrontEnd/Class.hs 335
-    (HsTyApp (HsTyCon className) _) = classApp
+    --(HsTyApp (HsTyCon className) _) = classApp
+    className = hsClassHead
hunk ./src/FrontEnd/Class.hs 436
+fromHsTyVar (HsTyVar v) = return v
+fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t
+fromHsTyVar _ = fail "fromHsTyVar"
+
hunk ./src/FrontEnd/Class.hs 443
-    f (HsClassDecl sl t decls)
-        | HsTyApp (HsTyCon className) (HsTyVar argName)  <- tbody = do
+    f (HsClassDecl sl chead decls) = do
hunk ./src/FrontEnd/Class.hs 446
+                className = hsClassHead chead
+                [Just argName] = map fromHsTyVar (hsClassHeadArgs chead)
hunk ./src/FrontEnd/Class.hs 457
-        | otherwise = failSl sl "Invalid Class declaration."
hunk ./src/FrontEnd/Class.hs 458
-        HsQualType cntxt tbody = t
+        cntxt = hsClassHeadContext chead
+        --HsQualType cntxt tbody = t
hunk ./src/FrontEnd/Class.hs 461
-        (_,(_,classArgs')) = qtToClassHead kt t
+        (_,(_,classArgs')) = chToClassHead kt chead
hunk ./src/FrontEnd/HsErrors.hs 45
+    f _ d@HsTypeFamilyDecl { } = do
+        warn (srcLoc d) UnsupportedFeature "Type families currently not supported"
+    f l d@HsTypeDecl { } | l /= TopLevel= do
+        warn (srcLoc d) UnsupportedFeature "Type families currently not supported"
hunk ./src/FrontEnd/HsErrors.hs 62
-    f context@(InClass ts) decl@HsTypeDecl { hsDeclTArgs = as }
-        | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
+--    f context@(InClass ts) decl@HsTypeDecl { hsDeclTArgs = as }
+--        | any (not . isHsTyVar) as = warn (srcLoc decl) InvalidDecl $ "complex type arguments not allowed " ++ show context
hunk ./src/FrontEnd/HsErrors.hs 70
-    f TopLevel decl@HsClassDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InClass args)) decls
+--    f TopLevel decl@HsClassDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InClass args)) decls
+    f TopLevel decl@HsClassDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InClass (hsClassHeadArgs ch))) decls
hunk ./src/FrontEnd/HsParser.y 321
-      | 'class' srcloc ctype optfundep optcbody
+      | 'class' srcloc classhead optfundep optcbody
hunk ./src/FrontEnd/HsPretty.hs 270
-	   mySep [text "class", ppHsQualType qualType]
+	   mySep [text "class", ppClassHead qualType]
hunk ./src/FrontEnd/HsPretty.hs 273
-	   mySep [text "class", ppHsQualType qualType, text "where"]
+	   mySep [text "class", ppClassHead qualType, text "where"]
hunk ./src/FrontEnd/HsSyn.hs 166
-        hsDeclSrcLoc   :: SrcLoc,
-        hsDeclQualType :: HsQualType,
-        hsDeclDecls    :: [HsDecl]
+        hsDeclSrcLoc    :: SrcLoc,
+        hsDeclClassHead :: HsClassHead,
+        hsDeclDecls     :: [HsDecl]
hunk ./src/FrontEnd/HsSyn.hs 403
-data HsClassHead = HsClassHead { hsClassHeadContext :: HsContext, hsClassHead :: HsName, hsClassHeadArgs :: [HsType] }
+data HsClassHead = HsClassHead {
+    hsClassHeadContext :: HsContext,
+    hsClassHead :: HsName,
+    hsClassHeadArgs :: [HsType] }
hunk ./src/FrontEnd/KindInfer.hs 40
+import FrontEnd.Warning
hunk ./src/FrontEnd/KindInfer.hs 59
-    put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = putMap a >> putMap b >> putMap c
+    put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } =
+        putMap a >> putMap b >> putMap c
hunk ./src/FrontEnd/KindInfer.hs 90
+    kiSrcLoc  :: SrcLoc,
hunk ./src/FrontEnd/KindInfer.hs 98
-    deriving(Monad,MonadReader KiEnv,MonadIO,Functor)
+    deriving(Monad,MonadReader KiEnv,MonadIO,Functor,MonadWarn)
+
+instance MonadSrcLoc Ki where
+    getSrcLoc = asks kiSrcLoc
+instance MonadSetSrcLoc Ki where
+    withSrcLoc sl = local (\s -> s { kiSrcLoc = sl })
hunk ./src/FrontEnd/KindInfer.hs 108
---------------------------------------------------------------------------------
-
hunk ./src/FrontEnd/KindInfer.hs 128
-        return KiEnv { kiContext = [], kiEnv = env, kiVarnum = varnum, kiWhere = Other }
+        return KiEnv {
+            kiSrcLoc = bogusASrcLoc,
+            kiContext = [],
+            kiEnv = env,
+            kiVarnum = varnum,
+            kiWhere = Other }
hunk ./src/FrontEnd/KindInfer.hs 157
-mgu k1 k2 = fail $ "attempt to unify these two kinds: " ++ show k1 ++ " <-> " ++ show k2
+mgu k1 k2 = addWarn UnificationError ("attempt to unify these two kinds: " ++ show k1 ++ " <-> " ++ show k2)
hunk ./src/FrontEnd/KindInfer.hs 164
-    when (u `Set.member` freeVars k) $ fail $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k
+    when (u `Set.member` freeVars k) $ addWarn OccursCheck $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k
hunk ./src/FrontEnd/KindInfer.hs 368
+-- first pass over declarations adds classes to environment.
hunk ./src/FrontEnd/KindInfer.hs 370
-kiInitClasses ds =  sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds]
-                    >> sequence_ [ f (hsDeclName cad) [v | HsTyVar v <- hsDeclTypeArgs cad]
-                                   | cad@(HsClassAliasDecl {}) <- ds ]
-    where
-    f className args = do
-        args <- mapM (lookupKind KindSimple . toName TypeVal) args
-        extendEnv mempty { kindEnvClasses = Map.singleton (toName ClassName className) args }
+kiInitClasses ds = do
+--    sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds]
+--    sequence_ [ f (hsDeclName cad) [v | HsTyVar v <- hsDeclTypeArgs cad] | cad@(HsClassAliasDecl {}) <- ds ]
+    mapM_ kiInitDecl ds
+--    where
+--    f className args = do
+--        args <- mapM (lookupKind KindSimple . toName TypeVal) args
+--        extendEnv mempty { kindEnvClasses = Map.singleton className args }
+kiInitDecl :: HsDecl -> Ki ()
+kiInitDecl d = withSrcLoc (srcLoc d) (f d) where
+    f HsClassDecl { .. } = do
+        args <- mapM (\_ -> newKindVar KindAny) (hsClassHeadArgs hsDeclClassHead)
+        extendEnv mempty { kindEnvClasses =
+            Map.singleton (hsClassHead hsDeclClassHead) (map KVar args) }
+    f _ = return ()
hunk ./src/FrontEnd/KindInfer.hs 387
-kiDecl HsTypeFamilyDecl { .. } = do
-    kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName)
-    kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind)
-kiDecl HsDataDecl { hsDeclContext = context, hsDeclName = tyconName, hsDeclArgs = args, hsDeclCons = [], hsDeclHasKind = Just kk } = do
-    args <- mapM (lookupKind KindSimple . toName TypeVal) args
-    kc <- lookupKind KindAny (toName TypeConstructor tyconName)
-    kiApps' kc args (hsKindToKind kk)
-    mapM_ kiPred context
-kiDecl HsDataDecl { hsDeclContext = context, hsDeclName = tyconName, hsDeclArgs = args, hsDeclCons = condecls } = kiData context tyconName args condecls
-kiDecl HsNewTypeDecl { hsDeclContext = context, hsDeclName = tyconName, hsDeclArgs = args, hsDeclCon = condecl } = kiAlias context tyconName args condecl
-kiDecl HsTypeDecl { hsDeclName = name, hsDeclTArgs = args, hsDeclType = ty } = do
-    wh <- asks kiWhere
-    let theconstraint = if wh == Other then KindAny else KindSimple
-    kc <- lookupKind theconstraint (toName TypeConstructor name)
-    mv <- newKindVar theconstraint
-    kiApps kc args (KVar mv)
-    kiType' (KVar mv) ty
-kiDecl (HsTypeSig _ _ (HsQualType ps t)) = do
-    mapM_ kiPred ps
-    kiType kindStar t
-kiDecl (HsClassDecl _sloc qualType sigsAndDefaults) = ans where
-    HsQualType contxt (HsTyApp (HsTyCon _className) (HsTyVar classArg)) =  qualType
-    ans = do
+kiDecl d = withSrcLoc (srcLoc d) (f d) where
+    f HsTypeFamilyDecl { .. } = do
+        kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName)
+        kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind)
+    f HsDataDecl {
+            hsDeclContext = context,
+            hsDeclName = tyconName,
+            hsDeclArgs = args,
+            hsDeclCons = [],
+            hsDeclHasKind = Just kk } = do
+        args <- mapM (lookupKind KindSimple . toName TypeVal) args
+        kc <- lookupKind KindAny (toName TypeConstructor tyconName)
+        kiApps' kc args (hsKindToKind kk)
+        mapM_ kiPred context
+    f HsDataDecl { .. }    = kiData hsDeclContext hsDeclName hsDeclArgs hsDeclCons
+    f HsNewTypeDecl { .. } = kiAlias hsDeclContext hsDeclName hsDeclArgs hsDeclCon
+    f HsTypeDecl { hsDeclName = name, hsDeclTArgs = args, hsDeclType = ty } = do
+        wh <- asks kiWhere
+        let theconstraint = if wh == Other then KindAny else KindSimple
+        kc <- lookupKind theconstraint (toName TypeConstructor name)
+        mv <- newKindVar theconstraint
+        kiApps kc args (KVar mv)
+        kiType' (KVar mv) ty
+    f (HsTypeSig _ _ (HsQualType ps t)) = do
+        mapM_ kiPred ps
+        kiType kindStar t
+    f (HsClassDecl _sloc HsClassHead { .. } sigsAndDefaults) = do
+        let varLike HsTyVar {} = True
+            varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t
+            varLike _ = False
+        when (length hsClassHeadArgs /= 1) $
+            addWarn UnsupportedFeature "Multi-parameter type classes not supported"
+        unless (all varLike hsClassHeadArgs) $
+            addWarn InvalidDecl "Class parameters must be variables"
+        env <- getEnv
+        let ks = kindOfClass hsClassHead env
+            [fromHsTyVar -> Just classArg] = hsClassHeadArgs
+        zipWithM_ kiType' ks hsClassHeadArgs
+        mapM_ kiPred hsClassHeadContext
+        let rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty g) newClassBodies
+            newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
+            typeFromSig (HsTypeSig _sloc _names qualType) = qualType
+            g (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n')
+            g _ = Seq.empty
hunk ./src/FrontEnd/KindInfer.hs 432
-        mapM_ kiPred contxt
-        extendEnv mempty { kindEnvAssocs = Map.fromList assocs }
hunk ./src/FrontEnd/KindInfer.hs 435
-    numClassArgs = 1
-    newAssocs = [ (name,[ n | ~(HsTyVar n) <- names],t,names) | HsTypeDecl _sloc name names t <- sigsAndDefaults ]
-    assocs = [ (toName TypeConstructor n,(numClassArgs,length names - numClassArgs)) | (n,names,_,_) <- newAssocs ]
-    rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs)
-    newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
-    f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n')
-    f _ = Seq.empty
-    typeFromSig :: HsDecl -> HsQualType
-    typeFromSig (HsTypeSig _sloc _names qualType) = qualType
-kiDecl _ = return ()
+  --      HsQualType contxt (HsTyApp (HsTyCon _className) (HsTyVar classArg)) =  qualType
+  --      ans = do
+  --          carg <- lookupKind KindSimple (toName TypeVal classArg)
+  --          mapM_ kiPred contxt
+--            extendEnv mempty { kindEnvAssocs = Map.fromList assocs }
+--            mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn
+--            local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults
+
+--        numClassArgs = 1
+--        newAssocs = [ (name,[ n | ~(HsTyVar n) <- names],t,names) | HsTypeDecl _sloc name names t <- sigsAndDefaults ]
+--        assocs = [ (toName TypeConstructor n,(numClassArgs,length names - numClassArgs)) | (n,names,_,_) <- newAssocs ]
+--        rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs)
+--        newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
+--        f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n')
+--        f _ = Seq.empty
+--        typeFromSig :: HsDecl -> HsQualType
+--        typeFromSig (HsTypeSig _sloc _names qualType) = qualType
+    f _ = return ()
hunk ./src/FrontEnd/KindInfer.hs 590
+
+fromHsTyVar (HsTyVar v) = return v
+fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t
+fromHsTyVar _ = fail "fromHsTyVar"
hunk ./src/FrontEnd/Rename.hs 275
-    rename (HsClassDecl srcLoc hsQualType hsDecls) = do
+    rename (HsClassDecl srcLoc classHead hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 277
-        hsQualType' <- updateWithN TypeVal hsQualType $ renameClassHead hsQualType
-        doesClassMakeSense hsQualType'
+        classHead' <- updateWithN TypeVal (hsClassHeadArgs classHead) $ rename classHead
+        --doesClassMakeSense hsQualType'
hunk ./src/FrontEnd/Rename.hs 280
-        return (HsClassDecl srcLoc hsQualType' hsDecls')
+        return (HsClassDecl srcLoc classHead' hsDecls')
hunk ./src/FrontEnd/Rename.hs 740
+instance (UpdateTable a, UpdateTable b) => UpdateTable (a,b) where
+    getNames (a,b) = getNames a ++ getNames b
hunk ./src/FrontEnd/Tc/Module.hs 128
---    let importVarEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x == Name.Val ]
---        importDConsEnv = Map.fromList [ (x,y) | (x,y) <- Map.toList $ hoAssumps me, nameType x ==  Name.DataConstructor ]
hunk ./src/FrontEnd/Tc/Module.hs 130
-    --wdump FD.Progress $ do
-    --    putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])
-    -- 'processModule' doesn't need IO. We can use a plain writer+error monad.
hunk ./src/FrontEnd/Tc/Module.hs 135
-    --let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
hunk ./src/FrontEnd/Tc/Module.hs 138
-
hunk ./src/FrontEnd/TypeSyns.hs 130
-    hsQualType' <- renameHsQualType hsQualType undefined
+    hsQualType' <- renameHsClassHead hsQualType
hunk ./src/FrontEnd/TypeSyns.hs 159
+renameHsClassHead :: HsClassHead -> ScopeSM (HsClassHead)
+renameHsClassHead HsClassHead { .. }  = do
+      hsClassHeadContext <- renameHsContext hsClassHeadContext ()
+      hsClassHeadArgs <- mapM (flip renameHsType ()) hsClassHeadArgs
+      return HsClassHead { .. }
hunk ./src/FrontEnd/Utils.hs 18
-maybeGetDeclName (HsClassDecl _ qualType _) = case qualType of
-            HsQualType _cntxt t -> return $ leftMostTyCon t
-        where
-            leftMostTyCon (HsTyTuple ts) = error "leftMostTyCon applied to tuple" -- toTuple (length ts)
-            leftMostTyCon (HsTyApp t1 _) = leftMostTyCon t1
-            leftMostTyCon (HsTyVar _) = error "leftMostTyCon: applied to a variable"
-            leftMostTyCon (HsTyCon n) = (toName ClassName n)
-            leftMostTyCon x = error $ "leftMostTyCon: " ++ show x
+maybeGetDeclName HsClassDecl { hsDeclClassHead = h } = return $ toName ClassName $ hsClassHead h
hunk ./src/FrontEnd/Warning.hs 15
+import Control.Monad.Reader
hunk ./src/FrontEnd/Warning.hs 71
-processErrors' doDie ws = mapM_ s (snub ws) >> when (die && doDie) exitFailure >> return die where
+processErrors' _ [] = return False
+processErrors' doDie ws = putErrLn "" >> mapM_ s (snub ws) >> when (die && doDie) exitFailure >> return die where
hunk ./src/FrontEnd/Warning.hs 99
+    | UnsupportedFeature
hunk ./src/FrontEnd/Warning.hs 116
+    f UnsupportedFeature {} = True
hunk ./src/FrontEnd/Warning.hs 158
+instance MonadWarn m => MonadWarn (ReaderT a m) where
+    addWarning w = lift $ addWarning w
hunk ./src/Ho/ReadSource.hs 90
+    "bangpatterns" ==> FO.BangPatterns,
hunk ./src/Support/TempDir.hs 25
+import System.Posix.Signals
hunk ./src/Support/TempDir.hs 131
-    f (fromException -> Just UserInterrupt) = cleanUp >> throwIO UserInterrupt
+    f (fromException -> Just UserInterrupt) = cleanUp >> raiseSignal sigINT
hunk ./src/Support/TempDir.hs 181
-
-