[improve kind checking, kind check instance heads before typechecking pass, switch HsInstDecl to use the HsClassHead
John Meacham <john@repetae.net>**20120205000203
 Ignore-this: 98d55f47020b0ef0bbbaee76296d8534
] hunk ./regress/regress.prl 216
+            if(statf($r) eq 'INT') {
+                $result->{compile_status} = 'INT';
+                done();
+            }
hunk ./src/FrontEnd/Class.hs 231
-   (cntxt, (className, cargs@[convertedArgType])) = qtToClassHead kt qType
+   (cntxt, (className, cargs@[convertedArgType])) = chToClassHead kt qType
hunk ./src/FrontEnd/Class.hs 241
-qtToClassHead :: KindEnv -> HsQualType -> ([Pred],(Name,[Type]))
-qtToClassHead kt qt@(HsQualType cntx (HsTyApp (HsTyCon className) ty)) =
-    vtrace ("qtToClassHead" <+> show qt) $
-    let res = (map (hsAsstToPred kt) cntx,(toName ClassName className,
-                                           [runIdentity $ hsTypeToType (kiHsQualType kt (HsQualType cntx (HsTyTuple []))) ty]))
-    in vtrace ("=" <+> show res) res
-
hunk ./src/FrontEnd/Class.hs 243
-    vtrace ("qtToClassHead" <+> show qt) $
+    vtrace ("chToClassHead" <+> show qt) $
hunk ./src/FrontEnd/Class.hs 254
-createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t)| HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where
+createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where
hunk ./src/FrontEnd/Class.hs 269
-    (_,(className,_)) = qtToClassHead kt qualType
+    (_,(className,_)) = chToClassHead kt qualType
hunk ./src/FrontEnd/Class.hs 274
-
hunk ./src/FrontEnd/Class.hs 282
-
---instanceToTopDecls kt ch@(CH classHierarchy _) cad@(HsClassAliasDecl {})
---   = unzip $ map (aliasDefaultMethodToTopDecls kt methodSigs aliasName) $ methodGroups where
---   aliasName = toName ClassName (hsDeclName cad)
---   methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) (hsDeclDecls cad))
---   methodSigs = case Map.lookup aliasName classHierarchy  of
---           Nothing -> error $ "aliasDefaultInstanceToTopDecls: could not find class "
---                              ++ show aliasName ++ "in class hierarchy"
---           Just sigs -> concatMap (classAssumps . findClassRecord ch) (classClasses sigs)
-
hunk ./src/FrontEnd/Class.hs 294
-    -> HsQualType
+    -> HsClassHead
hunk ./src/FrontEnd/Class.hs 298
---methodToTopDecls ch kt preds crecord@(ClassAliasRecord {}) qt meth@(methodName, methodDecls)
---   = methodToTopDecls ch kt preds (findClassRecord ch cls) qt meth
---     where Just cls = Map.lookup methodName (classMethodMap crecord)
-
hunk ./src/FrontEnd/Class.hs 300
-    (cntxt,(className,[argType])) = qtToClassHead kt qt
+    (cntxt,(className,[argType])) = chToClassHead kt qt
hunk ./src/FrontEnd/Class.hs 310
-
hunk ./src/FrontEnd/Class.hs 451
-        -- TODO check for duplicates here?
-        --
hunk ./src/FrontEnd/HsErrors.hs 9
-import Control.Monad
-
hunk ./src/FrontEnd/HsErrors.hs 15
-import Name.Names
hunk ./src/FrontEnd/HsErrors.hs 69
-    f TopLevel decl@HsInstDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InInstance args)) decls
+    f TopLevel decl@HsInstDecl { hsDeclClassHead = ch, hsDeclDecls = decls } = do mapM_ (f (InInstance (hsClassHeadArgs ch))) decls
+    --f TopLevel decl@HsInstDecl { hsDeclQualType = qt, hsDeclDecls = decls } = do args <- fetchQtArgs (srcLoc decl) qt; mapM_ (f (InInstance args)) decls
hunk ./src/FrontEnd/HsParser.y 329
-      | 'instance' srcloc ctype optvaldefs
+      | 'instance' srcloc classhead optvaldefs
hunk ./src/FrontEnd/HsPretty.hs 286
-	   mySep [text "instance", ppHsQualType qualType]
+	   mySep [text "instance", ppClassHead qualType]
hunk ./src/FrontEnd/HsPretty.hs 289
-	   mySep [text "instance", ppHsQualType qualType, text "where"]
+	   mySep [text "instance", ppClassHead qualType, text "where"]
hunk ./src/FrontEnd/HsSyn.hs 179
-        hsDeclSrcLoc   :: SrcLoc,
-        hsDeclQualType :: HsQualType,
-        hsDeclDecls    :: [HsDecl]
+        hsDeclSrcLoc    :: SrcLoc,
+        hsDeclClassHead :: HsClassHead,
+        hsDeclDecls     :: [HsDecl]
hunk ./src/FrontEnd/KindInfer.hs 157
-mgu k1 k2 = addWarn UnificationError ("attempt to unify these two kinds: " ++ show k1 ++ " <-> " ++ show k2)
+mgu k1 k2 = addWarn UnificationError $
+    "kind unification error, attempt to unify (" ++ show k1 ++ ") with (" ++ show k2 ++ ")"
hunk ./src/FrontEnd/KindInfer.hs 249
+{-# NOINLINE kiDecls #-}
hunk ./src/FrontEnd/KindInfer.hs 364
-        Just ks -> zipWithM_ f ks ns
+        Just ks -> do
+            when (length ks /= length ns) $
+                addWarn InvalidDecl ("Incorrect number of class parameters for " ++ show n)
+            zipWithM_ f ks ns
hunk ./src/FrontEnd/KindInfer.hs 376
---    sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds]
---    sequence_ [ f (hsDeclName cad) [v | HsTyVar v <- hsDeclTypeArgs cad] | cad@(HsClassAliasDecl {}) <- ds ]
hunk ./src/FrontEnd/KindInfer.hs 377
---    where
---    f className args = do
---        args <- mapM (lookupKind KindSimple . toName TypeVal) args
---        extendEnv mempty { kindEnvClasses = Map.singleton className args }
hunk ./src/FrontEnd/KindInfer.hs 387
+    varLike HsTyVar {} = True
+    varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t
+    varLike _ = False
hunk ./src/FrontEnd/KindInfer.hs 416
-        let varLike HsTyVar {} = True
-            varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t
-            varLike _ = False
hunk ./src/FrontEnd/KindInfer.hs 433
-
+    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
+        unless (all consLike hsClassHeadArgs) $
+            addWarn InvalidDecl "Instance parameters must be of the form 'C v1 v2'"
+        mapM_ kiPred hsClassHeadContext
+        env <- getEnv
+        let ks = kindOfClass hsClassHead env
+        when (length ks /= length hsClassHeadArgs) $
+            addWarn InvalidDecl "Incorrect number of class parameters in instance head"
+        zipWithM_ kiType' ks hsClassHeadArgs
+    f _ = return ()
hunk ./src/FrontEnd/KindInfer.hs 465
-    f _ = return ()
+
+fromHsTypeApp t = f t [] where
+    f (HsTyApp a b) rs = f a (b:rs)
+    f t rs = (t,rs)
hunk ./src/FrontEnd/Rename.hs 290
-    rename (HsInstDecl srcLoc hsQualType hsDecls) = do
+    rename (HsInstDecl srcLoc classHead hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 292
-        updateWithN TypeVal hsQualType $ do
-        hsQualType' <- renameClassHead hsQualType
+        updateWithN TypeVal (hsClassHeadArgs classHead) $ do
+        classHead' <- rename classHead
+        --updateWithN TypeVal hsQualType $ do
+        --hsQualType' <- renameClassHead hsQualType
hunk ./src/FrontEnd/Rename.hs 297
-           map (qualifyInstMethod (getTypeClassModule hsQualType)) hsDecls
-        return (HsInstDecl srcLoc hsQualType' hsDecls')
+            hsDecls
+           --map (qualifyInstMethod (getTypeClassModule hsQualType)) hsDecls
+        return (HsInstDecl srcLoc classHead' hsDecls')
hunk ./src/FrontEnd/Tc/Module.hs 125
--- FIXME: Use an warnings+writer+error monad instead of IO.
+{-# NOINLINE tiModules #-}
hunk ./src/FrontEnd/Tc/Module.hs 151
-    kindInfo <- kiDecls importKindEnv classAndDataDecls
+    kindInfo <- kiDecls importKindEnv ds -- classAndDataDecls
hunk ./src/FrontEnd/Tc/Module.hs 157
+    processIOErrors
hunk ./src/FrontEnd/TypeSyns.hs 134
-    hsQualType' <- renameHsQualType hsQualType subTable
+    hsQualType' <- renameHsClassHead hsQualType