[remove old kind checking cruft
John Meacham <john@repetae.net>**20061108062818] hunk ./FrontEnd/KindInfer.hs 200
-lookupKindEnv :: Name -> Ki (Maybe Kind)
-lookupKindEnv name = do
-    KindEnv { kindEnv = env } <- getEnv
-    return $ Map.lookup name env
hunk ./FrontEnd/KindInfer.hs 229
-
-{-
-kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv
-kiDecls inputEnv classAndDataDecls = ans where
-    ans = do
-        (_,KindEnv env as) <- run
-        return (KindEnv env (Map.fromList (concatMap kgAssocs kindGroups) `mappend` as))
-    run = runKI inputEnv $ withContext ("kiDecls: " ++ show (map getDeclName classAndDataDecls)) $ mapM_ kiKindGroup kindGroups
-    kindGroups = map declsToKindGroup depGroups
-    depGroups = getDataAndClassBg classAndDataDecls
--}
-
hunk ./FrontEnd/KindInfer.hs 404
-{-
-kiDecl (HsClassDecl _sloc qualType sigsAndDefaults) = do
-        let newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
-            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 ]
-            numClassArgs = 1
-            rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs)
-            f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single n'
-            f _ = Seq.empty
-            foos = [ (name,names) | (name,names,_,_) <- newAssocs ]
-            (newClassDecl, newContext) = ((className, classArg:rn), contxt)
-            HsQualType contxt (HsTyApp (HsTyCon className) (HsTyVar classArg)) =  qualType
-        tell mempty { kgClassDecls = [newClassDecl], kgDataDecls = foos, kgContexts = newContext, kgQualTypes = newClassBodies, kgAssocs = assocs }
-
-
-
-kiKindGroup :: KindGroup -> KI ()
-kiKindGroup tap@KindGroup { kgClassDecls = classDecls, kgDataDecls = heads, kgContexts = context, kgTypes = dataBodies, kgQualTypes = classBodies } = do
-        withContext ("kiKindGroup: " ++ show tap) $ do
-        mapM_ kiClassDecl classDecls
-        mapM_ kiTyConDecl heads
-        mapM_ kiAsst context
-        dataBodyKinds <- mapM (kiType False) dataBodies        -- vars must be seen previously here (hence True)
-        --mapM_ (\k -> unify k Star) dataBodyKinds                set to true for existentials
-        classBodyKinds <- mapM (kiQualType False) classBodies  -- vars may not have been seen previously here (hence False)
-        --mapM_ (\k -> unify k Star) classBodyKinds
-        currentSubst <- getSubst
-        applySubstToEnv currentSubst
-        envVarsToStars
-
-
-kiTyConDecl :: (HsName,[HsName]) -> KI ()
-kiTyConDecl (tyconName, args) = do
-        argKindVars <- mapM newNameVar args
-        let tyConKind = foldr Kfun Star $ map snd argKindVars
-        let newEnv = KindEnv (Map.fromList $ [(toName TypeConstructor tyconName, tyConKind)] ++ argKindVars) mempty
-        extendEnv newEnv
-
-kiClassDecl :: (HsName,[HsName]) -> KI ()
---kiClassDecl nn | trace ("kiClassDecl: " ++ show nn) False = undefined
-kiClassDecl (className, argNames) = do
-        varKind <- newKindVar
-        let newEnv = KindEnv (Map.fromList $ (toName ClassName className, varKind): [(toName TypeVal argName, varKind) | argName <- argNames]) mempty
-        extendEnv newEnv
-
--- here we expext the classname to be already defined and should be in the
--- environment, we do not require that the variables will be defined
-kiAsst :: HsAsst -> KI Kind
-kiAsst x@(HsAsst className [argName]) = withContext ("kiAsst: " ++ show x) $ do
-    classKind <- lookupKindEnv (toName ClassName className)
-    case classKind of
-           Nothing -> fail $ "kiAsst: could not find kind information for class: " ++ show className
-           Just ck -> do argKind <- lookupKindEnv (toName TypeVal argName)
-                         case argKind of
-                            --Nothing -> error  $ "kiAsst: could not find kind information for class/arg: " ++ show className ++ "/" ++ show argName
-                            Nothing -> do varKind <- newKindVar
-					  extendEnv $ KindEnv (Map.singleton (toName TypeVal argName) varKind) mempty
-                                          unify ck varKind
-                                          return ck
-                            Just ak -> do unify ck ak
-                                          return ck
-
-kiQualType :: Bool -> HsQualType -> KI Kind
-kiQualType varExist qt@(HsQualType cntxt t) = do
-        withContext ("kiQualType: " ++ show qt) $ do
-        mapM_ kiAsst cntxt
-        kiType varExist t
-
-
--- boolean arg = True = throw error if var does not exist
---               False = if var does not exist then add it to the environment
-
-kiType :: Bool -> HsType -> KI Kind
-kiType _ tap@(HsTyCon name) = do
-        withContext ("kiType: " ++ show tap) $ do
-        tyConKind <- lookupKindEnv (toName TypeConstructor name)
-        case tyConKind of
-           Nothing
-              -> do env <- getEnv
-                    fail $ "kiType: could not find kind for this constructor: " ++ show name ++
-                         "\nin this kind environment:\n" ++ pprint env
-           Just k -> return k
-
-kiType varExist tap@(HsTyVar name) = do
-        withContext ("kiType: " ++ show tap) $ do
-        varKind <- lookupKindEnv (toName TypeVal name)
-        case varKind of
-           Nothing
-              -> case varExist of
-                    True
-                       -> fail $ "kiType: could not find kind for this type variable: " ++ show name
-                    False -> do varKind <- newKindVar
-				extendEnv $ KindEnv (Map.singleton (toName TypeVal name) varKind) mempty
-                                return varKind
-           Just k -> return k
-
--- kind(t1) = kind(t2) -> var
-
-kiType varExist tap@(HsTyApp t1 t2) = do
-        withContext ("kiType: " ++ show tap) $ do
-        k1 <- kiType varExist t1
-        k2 <- kiType varExist t2
-        varKind <- newKindVar
-        unify k1 (k2 `Kfun` varKind)
-        return varKind
-
--- kind(->) = * -> * -> *
--- kind (t1 -> t2) = *, |- kind(t1) = *, kind(t2) = *
-
-
-kiType varExist tap@(HsTyFun t1 t2) = do
-        withContext ("kiType: " ++ show tap) $ do
-        k1 <- kiType varExist t1
-        k2 <- kiType varExist t2
-        unify k1 Star
-        unify k2 KFunRet
-        return Star
-
--- kind (t1, t2, ..., tn) = *
--- |- kind(t1) = *, kind(t2) = *, ... , kind(tn) = *
-
-kiType varExist tap@(HsTyTuple ts) = do
-        withContext ("kiType: " ++ show tap) $ do
-        tsKs <- mapM (kiType varExist) ts
-        mapM_ (\k -> unify k Star) tsKs
-        return Star
-kiType varExist tap@(HsTyUnboxedTuple ts) = do
-        withContext ("kiType: " ++ show tap) $ do
-        tsKs <- mapM (kiType varExist) ts
-        mapM_ (\k -> unify k Star) tsKs
-        return KUTuple
-
-kiType varExist tap@(HsTyForall { hsTypeVars = vs, hsTypeType = qt }) = do
-    argKindVars <- mapM (newNameVar . hsTyVarBindName) vs
-    let newEnv = KindEnv (Map.fromList argKindVars) mempty
-    extendEnv newEnv
-    kiQualType varExist qt
-kiType varExist tap@(HsTyExists { hsTypeVars = vs, hsTypeType = qt }) = do
-    argKindVars <- mapM (newNameVar . hsTyVarBindName) vs
-    let newEnv = KindEnv (Map.fromList argKindVars) mempty
-    extendEnv newEnv
-    kiQualType varExist qt
-
-newNameVar :: HsName -> KI (Name, Kind)
-newNameVar n = do
-    newVar <- newKindVar
-    return (toName TypeVal n, newVar)
-
-
---------------------------------------------------------------------------------
-
--- code for getting the kinds of variables in type sigs
-
-
-{-
-kiHsQualTypePredPred :: KindEnv -> HsQualType -> KindEnv
-kiHsQualTypePredPred inputEnv qt@(HsQualType cntxt (HsTyApp (HsTyCon className) t))  = env newState where
-    (_, newState) = runKI inputEnv $ do
-        withContext ("kiQualTypePredPred: " ++ show qt) $ do
-        mapM_ kiAsst (cntxt)
-        kt <- kiType False t
-        Just ck <- lookupKindEnv className
-        unify kt ck
-        envVarsToStars
--}
-
---------------------------------------------------------------------------------
-
-getDataAndClassBg :: [HsDecl] -> [[HsDecl]]
-getDataAndClassBg decls = getBindGroups decls getDeclName dataAndClassDeps
-
-dataAndClassDeps :: HsDecl -> [Name]
-dataAndClassDeps (HsDataDecl _sloc cntxt _name _args condecls _derives)
-   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ concatMap conDeclToTypes condecls) ++ concatMap conDeclNames condecls
-dataAndClassDeps (HsNewTypeDecl _sloc cntxt _name _args condecl _derives)
-   = snub $ namesFromContext cntxt ++ (concatMap namesFromType $ conDeclToTypes condecl) ++ conDeclNames condecl
-dataAndClassDeps (HsClassDecl _sloc (HsQualType cntxt _classApp) decls)
-   = snub $ namesFromContext cntxt ++ (concat [ namesFromQualType (typeFromSig s) | s <- decls,  isHsTypeSig s])
-
-namesFromQualType :: HsQualType -> [Name]
-namesFromQualType (HsQualType cntxt t) = namesFromContext cntxt ++ namesFromType t
-
-namesFromType :: HsType -> [Name]
-namesFromType (HsTyFun t1 t2) = namesFromType t1 ++ namesFromType t2
-namesFromType (HsTyTuple ts) = concatMap namesFromType ts
-namesFromType (HsTyUnboxedTuple ts) = concatMap namesFromType ts
-namesFromType (HsTyApp t1 t2) = namesFromType t1 ++ namesFromType t2
-namesFromType (HsTyVar _) = []
-namesFromType (HsTyCon n) = [toName TypeConstructor n]
-namesFromType (HsTyForall _vs qt) = namesFromQualType qt -- map (toName TypeVal . hsTyVarBindName) vs
-namesFromType (HsTyExists _vs qt) = namesFromQualType qt -- map (toName TypeVal . hsTyVarBindName) vs
---namesFromType HsTyExists { hsTypeVars = vs } = map (toName TypeVal . hsTyVarBindName) vs
-
-namesFromContext :: HsContext -> [Name]
-namesFromContext cntxt = concatMap f cntxt where
-    f (HsAsst x xs) = toName ClassName x:map (toName TypeVal) xs
-    f (HsAsstEq a b) = namesFromType a ++ namesFromType b
-
---------------------------------------------------------------------------------
-
--- (type constructor name, arguments to constructor)
---type DataDeclHead = (HsName, [HsName])
--- (class decls, data decl heads, class and data contexts, types in body of data decl, types in body of class)
---type KindGroup = ([(HsName,[HsName])], [DataDeclHead], HsContext, [HsType], [HsQualType])
-
-data KindGroup = KindGroup {
-     kgClassDecls :: [(HsName,[HsName])],
-     kgDataDecls ::[(HsName, [HsName])],
-     kgContexts ::HsContext,
-     kgTypes ::[HsType],
-     kgAssocs :: [(Name,(Int,Int))],
-     kgQualTypes ::[HsQualType]
-     }
-     deriving(Show)
-    {-!derive: Monoid !-}
-
-
-declsToKindGroup ds = ans where
-    ans = execWriter (mapM_ f ds)
-    f (HsDataDecl _sloc context tyconName tyconArgs condecls _derives) = do
-        tell mempty { kgDataDecls = [(tyconName, tyconArgs)], kgContexts = context, kgTypes = concatMap conDeclToTypes condecls }
-    f (HsNewTypeDecl _sloc context tyconName tyconArgs condecl _derives) = do
-        tell mempty { kgDataDecls = [(tyconName, tyconArgs)], kgContexts = context, kgTypes = conDeclToTypes condecl }
-    f (HsTypeDecl _sloc name names t) = do
-        tell mempty { kgDataDecls = [(name,[ n | ~(HsTyVar n) <- names])] }
-    f (HsClassDecl _sloc qualType sigsAndDefaults) = do
-        let newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults
-            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 ]
-            numClassArgs = 1
-            rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs)
-            f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single n'
-            f _ = Seq.empty
-            foos = [ (name,names) | (name,names,_,_) <- newAssocs ]
-            (newClassDecl, newContext) = ((className, classArg:rn), contxt)
-            HsQualType contxt (HsTyApp (HsTyCon className) (HsTyVar classArg)) =  qualType
-        tell mempty { kgClassDecls = [newClassDecl], kgDataDecls = foos, kgContexts = newContext, kgQualTypes = newClassBodies, kgAssocs = assocs }
-
-
-conDeclToTypes :: HsConDecl -> [HsType]
-conDeclToTypes rd = map bangTypeToType (hsConDeclArgs rd)
-
-conDeclNames :: HsConDecl -> [Name]
-conDeclNames rd = map (toName TypeVal) $ map hsTyVarBindName $ hsConDeclExists rd
---conDeclToTypes (HsConDecl _sloc name bangTypes)
---   = map bangTypeToType bangTypes
---   = error $ "conDeclToType (HsRecDecl _lsoc _name _recs): not implemented yet"
-
-bangTypeToType :: HsBangType -> HsType
-bangTypeToType (HsBangedTy t) = t
-bangTypeToType (HsUnBangedTy t) = t
-
-
--}