[brand new kind checking algorithm
John Meacham <john@repetae.net>**20061108062805] {
hunk ./DataConstructors.hs 58
+import FrontEnd.Tc.Kind
hunk ./DataConstructors.hs 97
-kind KUTuple = eHash
-kind Star = eStar
+kind (KBase KUTuple) = eHash
+kind (KBase Star) = eStar
hunk ./E/FromHs.hs 105
-kind KUTuple = eHash
-kind Star = eStar
+kind (KBase KUTuple) = eHash
+kind (KBase Star) = eStar
hunk ./FlagDump.flags 15
+kind-steps  show steps of kind inference
hunk ./FrontEnd/Class.hs 254
--}
hunk ./FrontEnd/Class.hs 265
-
-flattenLeftTypeApplication :: HsType -> [HsType]
-flattenLeftTypeApplication t = flatTypeAcc t [] where
-   flatTypeAcc (HsTyApp t1 t2) acc = flatTypeAcc t1 (t2:acc)
-   flatTypeAcc nonTypApp acc = nonTypApp:acc
-
-
+-}
hunk ./FrontEnd/KindInfer.hs 20
+import Control.Monad.Reader
+import Data.List
+import Data.FunctorM
+import Util.Inst
hunk ./FrontEnd/KindInfer.hs 31
-import List (nub)
hunk ./FrontEnd/KindInfer.hs 48
+import qualified FlagDump as FD
+import Options
hunk ./FrontEnd/KindInfer.hs 54
-data KindEnv = KindEnv (Map.Map Name Kind) (Map.Map Name (Int,Int))
-    deriving(Typeable,Show)
+data KindEnv = KindEnv {
+    kindEnv :: Map.Map Name Kind,
+    kindEnvAssocs :: Map.Map Name (Int,Int),
+    kindEnvClasses :: Map.Map Name [Kind]
+    } deriving(Typeable,Show)
hunk ./FrontEnd/KindInfer.hs 62
-    size (KindEnv env _) = size env
+    size KindEnv { kindEnv = env } = size env
hunk ./FrontEnd/KindInfer.hs 64
-type Subst = [(Kindvar, Kind)]
+instance FreeVars Kind [Kindvar] where
+   freeVars (KVar kindvar) = [kindvar]
+   freeVars (kind1 `Kfun` kind2) = freeVars kind1 `union` freeVars kind2
+   freeVars KBase {} = []
hunk ./FrontEnd/KindInfer.hs 69
-nullSubst :: Subst
-nullSubst = []
-
-class Kinds a where
-   vars :: a -> [Kindvar]
-   apply :: Subst -> a -> a
-
-instance Kinds Kind where
-   vars Star = []
-   vars (KVar kindvar) = [kindvar]
-   vars (kind1 `Kfun` kind2) = vars kind1 ++ vars kind2
-
-   apply s Star = Star
-   apply s (KVar kindvar)
-      = case lookup kindvar s of
-           Just k -> k
-           Nothing -> KVar kindvar
-   apply s (kind1 `Kfun` kind2)
-      = (apply s kind1) `Kfun` (apply s kind2)
-
-instance Kinds a => Kinds [a] where
-   vars = nub . concatMap vars
-   apply s = map (apply s)
-
-instance Kinds a => Kinds (b, a) where
-   apply s (x, y) = (x, apply s y)
-   vars (x, y) = vars y
-
-instance Kinds KindEnv where
-   apply s (KindEnv m x) = KindEnv (Map.map (\el -> apply s el) m) x
-   vars (KindEnv env x) = vars $ map snd $ Map.toList env
hunk ./FrontEnd/KindInfer.hs 72
-    pprint (KindEnv m ev) = vcat $ [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] ++ [ text "associated type" <+> pprint n <+> pprint ab  | (n,ab) <- Map.toList ev] ++ [empty]
---------------------------------------------------------------------------------
-
--- unification
-
-composeSubst :: Subst -> Subst -> Subst
-composeSubst s1 s2 = [(u, apply s1 k) | (u, k) <- s2] ++ s1
-
-
-{-# SPECIALIZE mgu :: Kind -> Kind -> KI Subst #-}
-
--- can return either a substitution or a string
-mgu :: Monad m => Kind -> Kind -> m Subst
-mgu Star Star = return nullSubst
-mgu (k1 `Kfun` k2) (k3 `Kfun` k4) = do
-    s1 <- mgu k1 k3
-    s2 <- mgu (apply s1 k2) (apply s1 k4)
-    return (s2 `composeSubst` s1)
-mgu (KVar u) k = varBind u k
-mgu k (KVar u) = varBind u k
-mgu k1 k2 | isJust $ kindCombine k1 k2 = return nullSubst
-mgu k1 k2 = fail $ "attempt to unify these two kinds: " ++ show k1 ++ ", " ++ show k2
-
-{-# SPECIALIZE varBind :: Kindvar -> Kind -> KI Subst #-}
-
-varBind :: Monad m => Kindvar -> Kind -> m Subst
-varBind u k
-   | k == KVar u = return nullSubst
-   | u `elem` vars k = fail $ "occurs check failed in kind inference: " ++
-                               show u ++ ", " ++ show k
-   | otherwise = return [(u, k)]
-
+    pprint KindEnv { kindEnv = m, kindEnvAssocs = ev, kindEnvClasses = cs } = vcat $
+        [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] ++
+        [ text "associated type" <+> pprint n <+> pprint ab  | (n,ab) <- Map.toList ev] ++
+        [ text "class" <+> pprint n <+> pprint ab  | (n,ab) <- Map.toList cs] ++
+        [empty]
hunk ./FrontEnd/KindInfer.hs 80
+
hunk ./FrontEnd/KindInfer.hs 83
+data KiWhere = InClass | InInstance | Other
+    deriving(Eq)
+
hunk ./FrontEnd/KindInfer.hs 89
-    kiSubst :: IORef Subst,
+    kiWhere :: KiWhere,
hunk ./FrontEnd/KindInfer.hs 93
-newtype KI a = KI (KiEnv -> IO a)-- -> (a, State))
-
-
-instance Monad KI where
-    return a = KI (\_ -> return a)
-    KI comp >>= fun
-        = KI (\v  -> comp v >>= \r -> case fun r   of KI x -> x v)
-    fail x = KI (\s -> fail (unlines $ reverse (x:kiContext s)))
+newtype Ki a = Ki (ReaderT KiEnv IO a)
+    deriving(Monad,MonadReader KiEnv,MonadIO,Functor)
hunk ./FrontEnd/KindInfer.hs 98
-restrictKindEnv f (KindEnv m x) = KindEnv (Map.filterWithKey (\k _ -> f k) m) x
+restrictKindEnv f ke = ke { kindEnv = Map.filterWithKey (\k _ -> f k) (kindEnv ke) }
hunk ./FrontEnd/KindInfer.hs 102
+findKind :: MonadIO m => Kind -> m Kind
+findKind tv@(KVar Kindvar {kvarRef = r, kvarConstraint = con }) = liftIO $ do
+    rt <- readIORef r
+    case rt of
+        Nothing
+            | con == KindStar -> writeIORef r (Just kindStar) >> return kindStar
+            | otherwise -> return tv
+        Just t -> do
+            t' <- findKind t
+            writeIORef r (Just t')
+            return t'
+findKind tv = return tv
+
hunk ./FrontEnd/KindInfer.hs 117
-runKI :: KindEnv -> KI a -> IO (a, KindEnv)
-runKI env (KI ki) = (kienv >>= ki') where
+runKI :: KindEnv -> Ki a -> IO a
+runKI env (Ki ki) = (kienv >>= ki') where
hunk ./FrontEnd/KindInfer.hs 121
-        subst <- newIORef nullSubst
hunk ./FrontEnd/KindInfer.hs 122
-        return KiEnv { kiContext = [], kiEnv = env, kiSubst = subst, kiVarnum = varnum }
-    ki' e = do
-        x <- ki e
-        env <- readIORef (kiEnv e)
-        return (x,env)
+        return KiEnv { kiContext = [], kiEnv = env, kiVarnum = varnum, kiWhere = Other }
+    ki' e = runReaderT ki e
hunk ./FrontEnd/KindInfer.hs 126
-instance ContextMonad String KI where
-    withContext nc (KI x)= KI (\s -> x s { kiContext = nc :kiContext s })
+instance ContextMonad String Ki where
+    withContext nc x = local (\s -> s { kiContext = nc :kiContext s }) x
hunk ./FrontEnd/KindInfer.hs 129
-getSubst :: KI Subst
-getSubst = KI $ \e -> do
-    readIORef (kiSubst e)
hunk ./FrontEnd/KindInfer.hs 130
-getVarNum :: KI Int
-getVarNum = KI $ \e -> do
-    readIORef (kiVarnum e)
+getEnv :: Ki KindEnv
+getEnv = do asks kiEnv >>= liftIO . readIORef
hunk ./FrontEnd/KindInfer.hs 133
-getEnv :: KI KindEnv
-getEnv = KI $ \e -> readIORef (kiEnv e)
hunk ./FrontEnd/KindInfer.hs 134
+unify :: Kind -> Kind -> Ki ()
+unify k1 k2 = do
+    k1 <- flattenKind k1
+    k2 <- flattenKind k2
+    printRule $ "unify:" <+> pprint k1 <+> text "<->" <+> pprint k2
+    mgu k1 k2
hunk ./FrontEnd/KindInfer.hs 141
-getEnvVars :: KI [Kindvar]
-getEnvVars
-   = do e <- getEnv
-        return $ vars e
+mgu :: Kind -> Kind -> Ki ()
+mgu (KBase a) (KBase b) | a == b = return ()
+mgu (Kfun a b) (Kfun a' b') = do
+    unify a a'
+    unify b b'
+mgu (KVar u) k = varBind u k
+mgu k (KVar u) = varBind u k
+mgu k1 k2 = fail $ "attempt to unify these two kinds: " ++ show k1 ++ " <-> " ++ show k2
hunk ./FrontEnd/KindInfer.hs 150
-incVarNum :: KI ()
-incVarNum = KI $ \e -> do
-    n <- readIORef (kiVarnum e)
-    writeIORef (kiVarnum e ) $! (n + 1)
+varBind :: Kindvar -> Kind -> Ki ()
+varBind u k = do
+    k <- flattenKind k
+    printRule $ "varBind:" <+> pprint u <+> text ":=" <+> pprint k
+    if k == KVar u then return () else do
+    when (u `elem` freeVars k) $ fail $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k
+    v <- liftIO $ readIORef (kvarRef u)
+    case v of
+        Just v -> fail $ "varBind unfree"
+        Nothing -> do
+            liftIO $ writeIORef (kvarRef u) (Just k)
+            constrain (kvarConstraint u) k
hunk ./FrontEnd/KindInfer.hs 163
-unify :: Kind -> Kind -> KI ()
-unify k1 k2 = do
-    s <- getSubst
-    newSubst <- mgu (apply s k1) (apply s k2)
-    extendSubst newSubst
-    --case mgu (apply s k1) (apply s k2) of
-    --       Right newSubst  -> extendSubst newSubst
-    --       Left errorMsg -> error $ unlines (reverse c ++ [errorMsg])
+zonkConstraint :: KindConstraint -> Kindvar -> Ki ()
+zonkConstraint nk mv = do
+    let fk = mappend nk (kvarConstraint mv)
+    if fk == kvarConstraint mv then return () else do
+        nref <- liftIO $ newIORef Nothing
+        let nmv = mv { kvarConstraint = fk, kvarRef = nref }
+        liftIO $ modifyIORef (kvarRef mv) (\Nothing -> Just $ KVar nmv)
hunk ./FrontEnd/KindInfer.hs 171
+constrain KindAny k = return ()
+constrain KindStar (KBase Star) = return ()
+constrain KindFunRet (KBase _) = return ()
+constrain KindSimple (KBase Star) = return ()
+constrain KindSimple (a `Kfun` b) = do
+    a <- findKind a
+    b <- findKind b
+    constrain KindSimple a
+    constrain KindSimple b
+constrain con (KVar v) = zonkConstraint con v
+constrain con k = fail $ "constraining kind: " ++ show (con,k)
hunk ./FrontEnd/KindInfer.hs 183
-extendSubst :: Subst -> KI ()
-extendSubst s = KI $ \e -> do
-    modifyIORef (kiSubst e) (s `composeSubst`)
hunk ./FrontEnd/KindInfer.hs 184
-newKindVar :: KI Kind
-newKindVar
-   = do n <- getVarNum
-        incVarNum
-        return (KVar (Kindvar n))
+flattenKind :: Kind -> Ki Kind
+flattenKind k = f' k where
+    f (a `Kfun` b) = return Kfun `ap` f' a `ap` f' b
+    f k = return k
+    f' k = findKind k >>= f
hunk ./FrontEnd/KindInfer.hs 190
-lookupKindEnv :: Name -> KI (Maybe Kind)
+
+newKindVar :: KindConstraint -> Ki Kindvar
+newKindVar con = do
+    KiEnv { kiVarnum = vr } <- ask
+    liftIO $ do
+    n <- readIORef vr
+    writeIORef vr $! (n + 1)
+    nr <- newIORef Nothing
+    return Kindvar { kvarUniq = n, kvarRef = nr, kvarConstraint = con }
+
+lookupKindEnv :: Name -> Ki (Maybe Kind)
hunk ./FrontEnd/KindInfer.hs 202
-    KindEnv env _ <- getEnv
+    KindEnv { kindEnv = env } <- getEnv
hunk ./FrontEnd/KindInfer.hs 205
-extendEnv :: KindEnv -> KI ()
-extendEnv (KindEnv newEnv nx) = KI $ \e ->
-    modifyIORef (kiEnv e) (\ (KindEnv env x) -> KindEnv (env `Map.union` newEnv) (nx `mappend` x))
-
-applySubstToEnv :: Subst -> KI ()
-applySubstToEnv subst = KI $ \e ->
-    modifyIORef (kiEnv e) (apply subst)
+lookupKind :: KindConstraint -> Name -> Ki Kind
+lookupKind con name = do
+    KindEnv { kindEnv = env } <- getEnv
+    case Map.lookup name env of
+        Just k -> do
+            k <- findKind k
+            constrain con k
+            findKind k
+        Nothing -> do
+            kv <- newKindVar con
+            extendEnv mempty { kindEnv = Map.singleton name (KVar kv) }
+            return (KVar kv)
hunk ./FrontEnd/KindInfer.hs 218
-envVarsToStars :: KI ()
-envVarsToStars
-   = do vars <- getEnvVars
-        let varsToStarSubst = map (\v -> (v, Star)) vars   -- clobber all remaining variables to stars
-        applySubstToEnv varsToStarSubst
+extendEnv :: KindEnv -> Ki ()
+extendEnv newEnv = do
+    ref <- asks kiEnv
+    liftIO $ modifyIORef ref (mappend newEnv) -- (\ (KindEnv env x) -> KindEnv (env `Map.union` newEnv) (nx `mappend` x))
hunk ./FrontEnd/KindInfer.hs 225
-getConstructorKinds (KindEnv m _) = m -- Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m]
+getConstructorKinds ke = kindEnv ke -- Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m]
hunk ./FrontEnd/KindInfer.hs 231
+
+
+
+{-
hunk ./FrontEnd/KindInfer.hs 243
+-}
+
+printRule :: String -> Ki ()
+printRule s
+    | dump FD.KindSteps = liftIO $ putStrLn s
+    | otherwise = return ()
+
+kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv
+kiDecls inputEnv classAndDataDecls = ans where
+    ans = do
+        ke <- run
+        return ke -- TODO (Map.fromList (concatMap kgAssocs kindGroups) `mappend` as))
+    run = runKI inputEnv $ withContext ("kiDecls: " ++ show (map getDeclName classAndDataDecls)) $ do
+        kiInitClasses classAndDataDecls
+        mapM_ kiDecl classAndDataDecls
+        getEnv >>= postProcess
+
+postProcess ke = do
+    kindEnv <- fmapM flattenKind (kindEnv ke)
+    kindEnvClasses <- fmapM (mapM flattenKind) (kindEnvClasses ke)
+    let defs = snub (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses))
+    printRule $ "defaulting the following kinds: " ++ pprint defs
+    mapM_ (flip varBind kindStar) defs
+    kindEnv <- fmapM flattenKind kindEnv
+    kindEnvClasses <- fmapM (mapM flattenKind) kindEnvClasses
+    return ke { kindEnvClasses = kindEnvClasses, kindEnv = kindEnv }
+
+
+kiType,kiType' :: Kind -> HsType -> Ki ()
+kiType' k t = do
+    k <- findKind k
+    kiType k t
+
+kiType k (HsTyTuple ts) = do
+    unify kindStar k
+    mapM_ (kiType kindStar) ts
+kiType k (HsTyUnboxedTuple ts) = do
+    unify kindUTuple k
+    mapM_ (kiType kindStar) ts
+kiType k (HsTyFun a b) = do
+    unify kindStar k
+    kiType kindStar a
+    kv <- newKindVar KindFunRet
+    kiType (KVar kv) b
+kiType k (HsTyApp a b) = do
+    kv <- newKindVar KindAny
+    kiType  (KVar kv `Kfun` k) a
+    kiType' (KVar kv) b
+kiType k (HsTyVar v) = do
+    kv <- lookupKind KindSimple (toName TypeVal v)
+    unify k kv
+kiType k (HsTyCon v) = do
+    kv <- lookupKind KindAny (toName TypeConstructor v)
+    unify k kv
+kiType k (HsTyCon v) = do
+    kv <- lookupKind KindAny (toName TypeConstructor v)
+    unify k kv
+kiType k HsTyAssoc = do
+    constrain KindSimple k
+kiType _ HsTyEq {} = error "kiType.HsTyEq"
+kiType k HsTyForall { hsTypeVars = vs, hsTypeType = HsQualType con t } = do
+    mapM initTyVarBind vs
+    mapM_ kiPred con
+    kiType' k t
+kiType k HsTyExists { hsTypeVars = vs, hsTypeType = HsQualType con t } = do
+    mapM initTyVarBind vs
+    mapM_ kiPred con
+    kiType' k t
+
+initTyVarBind HsTyVarBind { hsTyVarBindName = name, hsTyVarBindKind = kk } = do
+    nk <- lookupKind KindSimple (toName TypeVal name)
+    case kk of
+        Nothing -> return ()
+        Just kk -> unify nk (hsKindToKind kk)
+
+
+
+hsKindToKind (HsKindFn a b) = hsKindToKind a `Kfun` hsKindToKind b
+hsKindToKind a | a == hsKindStar = kindStar
+
+kiApps :: Kind -> [HsType] -> Kind -> Ki ()
+kiApps ca args fk = f ca args fk where
+    f ca [] fk = unify ca fk
+    f (x `Kfun` y) (a:as) fk = do
+        kiType' x a
+        y <- findKind y
+        f y as fk
+    f (KVar var) as fk = do
+        x <- newKindVar KindAny
+        y <- newKindVar KindAny
+        let nv = (KVar x `Kfun` KVar y)
+        varBind var nv
+        f nv as fk
+
+kiApps' :: Kind -> [Kind] -> Kind -> Ki ()
+kiApps' ca args fk = f ca args fk where
+    f ca [] fk = unify ca fk
+    f (x `Kfun` y) (a:as) fk = do
+        unify a x
+        y <- findKind y
+        f y as fk
+    f (KVar var) as fk = do
+        x <- newKindVar KindAny
+        y <- newKindVar KindAny
+        let nv = (KVar x `Kfun` KVar y)
+        varBind var nv
+        f nv as fk
+
+kiPred :: HsAsst -> Ki ()
+kiPred asst@(HsAsst n ns) = do
+    env <- getEnv
+    let f k n = do
+            k' <- lookupKind KindSimple (toName TypeVal n)
+            unify k k'
+    case Map.lookup (toName ClassName n) (kindEnvClasses env) of
+        Nothing -> fail $ "unknown class: " ++ show asst
+        Just ks -> zipWithM_ f ks ns
+kiPred (HsAsstEq a b) = do
+    mv <- newKindVar KindSimple
+    kiType  (KVar mv) a
+    kiType' (KVar mv) b
+
+kiInitClasses :: [HsDecl] -> Ki ()
+kiInitClasses ds =  sequence_ [ f className [classArg] |  HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon className) (HsTyVar classArg))) _ <- ds] where
+    f className args = do
+        args <- mapM (lookupKind KindSimple . toName TypeVal) args
+        extendEnv mempty { kindEnvClasses = Map.singleton (toName ClassName className) args }
+
+
+
+kiDecl :: HsDecl -> Ki ()
+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 } = kiData 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
+        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
+kiDecl _ = return ()
+
+kiData context tyconName args condecls = do
+    args <- mapM (lookupKind KindSimple . toName TypeVal) args
+    kc <- lookupKind KindSimple (toName TypeConstructor tyconName)
+    kiApps' kc args kindStar
+    mapM_ kiPred context
+    mapM_ (kiType kindStar) (concatMap (map hsBangType . hsConDeclArgs) condecls)
+
+kiHsQualType :: KindEnv -> HsQualType -> KindEnv
+kiHsQualType inputEnv qualType@(HsQualType ps t) = newState where
+    newState = unsafePerformIO $ runKI inputEnv $ withContext ("kiHsQualType: " ++ show qualType) $ do
+        kiType kindStar t
+        mapM_ kiPred ps
+        getEnv >>= postProcess
+
+{-
+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 }
+
+
hunk ./FrontEnd/KindInfer.hs 535
-        unify k2 Star
+        unify k2 KFunRet
hunk ./FrontEnd/KindInfer.hs 573
-kiHsQualType :: KindEnv -> HsQualType -> KindEnv
-kiHsQualType inputEnv qualType = newState where
-    (_, newState) = unsafePerformIO $ runKI inputEnv $ withContext ("kiHsQualType: " ++ show qualType) $ do
-        kiQualType False qualType
-        currentSubst <- getSubst
-        applySubstToEnv currentSubst
-        envVarsToStars
hunk ./FrontEnd/KindInfer.hs 672
-typeFromSig :: HsDecl -> HsQualType
-typeFromSig (HsTypeSig _sloc _names qualType) = qualType
-
+
+-}
+
hunk ./FrontEnd/KindInfer.hs 678
-kindOf name (KindEnv env _) = case Map.lookup name env of
-            Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> Star
+kindOf name KindEnv { kindEnv = env } = case Map.lookup name env of
+            Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar
hunk ./FrontEnd/KindInfer.hs 684
-kindOfClass name (KindEnv env _) = case Map.lookup name env of
+kindOfClass name KindEnv { kindEnvClasses = cs } = case Map.lookup name cs of
hunk ./FrontEnd/KindInfer.hs 687
-        Just k -> [k]
+        Just k -> k
hunk ./FrontEnd/KindInfer.hs 699
-aHsTypeToType kt@(KindEnv _ at) t | (HsTyCon con,xs) <- fromTyApp t, let nn = toName TypeConstructor con, Just (n1,n2) <- Map.lookup nn at =
+aHsTypeToType kt@KindEnv { kindEnvAssocs = at } t | (HsTyCon con,xs) <- fromTyApp t, let nn = toName TypeConstructor con, Just (n1,n2) <- Map.lookup nn at =
hunk ./FrontEnd/KindInfer.hs 757
+   --newEnv = kindEnv
hunk ./FrontEnd/Representation.hs 87
-    tBool = TCon (Tycon tc_Bool Star)
+    tBool = TCon (Tycon tc_Bool kindStar)
hunk ./FrontEnd/Representation.hs 89
-    tChar      = TCon (Tycon tc_Char Star)
-    tUnit = TCon (Tycon tc_Unit Star)
+    tChar      = TCon (Tycon tc_Char kindStar)
+    tUnit = TCon (Tycon tc_Unit kindStar)
hunk ./FrontEnd/Representation.hs 95
-tList = TCon (Tycon tc_List (Kfun Star Star))
+tList = TCon (Tycon tc_List (Kfun kindStar kindStar))
hunk ./FrontEnd/Representation.hs 150
-    toTuple n = Tycon (nameTuple TypeConstructor n) (foldr Kfun Star $ replicate n Star)
+    toTuple n = Tycon (nameTuple TypeConstructor n) (foldr Kfun kindStar $ replicate n kindStar)
hunk ./FrontEnd/Representation.hs 234
-    x@Star -> newLookupName (map (:[]) ['a' ..]) x t
-    y@(Star `Kfun` Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t
-    z@KUTuple -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t
-    z@KFunRet -> newLookupName (map (('r':) . show) [0 :: Int ..]) z t
+    x@(KBase Star) -> newLookupName (map (:[]) ['a' ..]) x t
+    y@(KBase Star `Kfun` KBase Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t
+    z@(KBase KUTuple) -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t
+    z@(KBase KFunRet) -> newLookupName (map (('r':) . show) [0 :: Int ..]) z t
hunk ./FrontEnd/Representation.hs 312
-        | Star <- k =  pprint t <> tshow u
+        | KBase Star <- k =  pprint t <> tshow u
hunk ./FrontEnd/Representation.hs 339
-  getType (TArrow _l _r) = Star
+  getType (TArrow _l _r) = kindStar
hunk ./FrontEnd/Representation.hs 348
-tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor  n) (foldr Kfun KUTuple $ replicate n Star)) ts where
+tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor  n) (foldr Kfun kindUTuple $ replicate n kindStar)) ts where
hunk ./FrontEnd/Tc/Class.hs 27
+import FrontEnd.Tc.Kind
hunk ./FrontEnd/Tc/Class.hs 222
-    | otherwise = map (\name -> TCon (Tycon name Star)) [tc_Integer, tc_Double]
+    | otherwise = map (\name -> TCon (Tycon name kindStar)) [tc_Integer, tc_Double]
hunk ./FrontEnd/Tc/Kind.hs 3
+    KBase(..),
hunk ./FrontEnd/Tc/Kind.hs 5
+    KindConstraint(..),
hunk ./FrontEnd/Tc/Kind.hs 7
+    kindStar,
+    kindUTuple,
+    kindFunRet,
hunk ./FrontEnd/Tc/Kind.hs 13
+import Data.Monoid
hunk ./FrontEnd/Tc/Kind.hs 16
+import Data.IORef
hunk ./FrontEnd/Tc/Kind.hs 24
- KFunRet = ??
+ KFunRet = ?
hunk ./FrontEnd/Tc/Kind.hs 31
-   ??
-  /  \
- *   (#)
+   ?
+  / \
+ *  (#)
hunk ./FrontEnd/Tc/Kind.hs 38
-data Kind  = Star
+data KBase = Star | KUTuple | KFunRet
+    deriving(Data,Typeable, Eq, Ord)   -- but we need them for kind inference
+    {-! derive: GhcBinary !-}
+
+kindStar = KBase Star
+kindUTuple = KBase KUTuple
+kindFunRet = KBase KFunRet
+
+data Kind  = KBase KBase
hunk ./FrontEnd/Tc/Kind.hs 48
-           | KUTuple                    -- ^ kind of unboxed tuples
-           | KFunRet                    -- ^ either a * or a (#)
hunk ./FrontEnd/Tc/Kind.hs 52
+
hunk ./FrontEnd/Tc/Kind.hs 54
-kindCombine x y = f x y where
+kindCombine x y = g x y where
hunk ./FrontEnd/Tc/Kind.hs 63
-    f (Kfun a b) (Kfun a' b') = return Kfun `ap` f a a' `ap` f b b'
hunk ./FrontEnd/Tc/Kind.hs 64
+    g (KBase x) (KBase y) = f x y >>= return . KBase
+    g (Kfun a b) (Kfun a' b') = return Kfun `ap` g a a' `ap` g b b'
+    g x y = fail $ "kindCombine: " ++ show (x,y)
+
+data KindConstraint
+    = KindSimple  -- ^ * | kindSimple -> kindSimple
+    | KindFunRet  -- ^ ??, so * or (#) or ??
+    | KindStar    -- ^ must be *
+    | KindAny     -- ^ no constraints
+    deriving(Eq,Ord,Typeable,Data,Show)
+
+instance Monoid KindConstraint where
+    mempty = KindAny
+    mappend a b | a == b = a
+    mappend KindAny k = k
+    mappend KindStar _ = KindStar
+    mappend KindSimple KindFunRet = KindStar
+    mappend k1 k2 = mappend k2 k1
hunk ./FrontEnd/Tc/Kind.hs 83
+data Kindvar = Kindvar {
+    kvarUniq :: !Int,
+    kvarRef :: IORef (Maybe Kind),
+    kvarConstraint :: KindConstraint
+    } deriving
+    (Data,Typeable)
hunk ./FrontEnd/Tc/Kind.hs 90
-newtype Kindvar = Kindvar Int deriving
-    (Data,Binary,Typeable,Ord,Eq,Show)
+instance Binary Kindvar where
+    put_ _ _ = return ()
+    get _ = return (error "Binary.Kindvar.get")
+
+instance Eq Kindvar where
+    a == b = kvarUniq a == kvarUniq b
+instance Ord Kindvar where
+    a `compare` b = kvarUniq a `compare` kvarUniq b
hunk ./FrontEnd/Tc/Kind.hs 102
+instance Show Kindvar where
+    showsPrec _ k = pprint k
+
+
+instance Show KBase where
+    showsPrec _ Star = showString "*"
+    showsPrec _ KUTuple = showString "(#)"
+    showsPrec _ KFunRet = showString "?"
+
+instance DocLike d => PPrint d KBase where
+    pprint kb = text (show kb)
+
hunk ./FrontEnd/Tc/Kind.hs 115
-   pprint Star = text "*"
-   pprint KUTuple = text "(#)"
-   pprint KFunRet = text "??"
-   pprint (Kfun Star k2)   = text "* -> " <> pprint k2
-   pprint (Kfun KUTuple k2)   = text "(#) -> " <> pprint k2  -- ^ this is invalid
-   pprint (Kfun KFunRet k2)   = text "?? -> " <> pprint k2  -- ^ this is invalid
-   pprint (Kfun k1   Star) = text "(" <> pprint k1 <> text ")" <> text " -> *"
-   pprint (Kfun k1   KUTuple) = text "(" <> pprint k1 <> text ")" <> text " -> (#)"
-   pprint (Kfun k1   KFunRet) = text "(" <> pprint k1 <> text ")" <> text " -> ??"
-   pprint (Kfun k1   k2)   = text "(" <> pprint k1 <> text ") -> (" <> pprint k2 <> text ")"
+   pprint (KBase b) = pprint b
hunk ./FrontEnd/Tc/Kind.hs 117
+   pprint (Kfun (KBase b) k2)   = pprint b <+> text "->" <+> pprint k2
+   pprint (Kfun (KVar b)  k2)   = pprint b <+> text "->" <+> pprint k2
+   pprint (Kfun k1   b) = text "(" <> pprint k1 <> text ")" <+> text "->" <+> pprint b
+--   pprint (Kfun k1   (KVar b)) = text "(" <> pprint k1 <> text ")" <+> text "->" <+> pprint b
+--   pprint (Kfun k1   k2)   = text "(" <> pprint k1 <> text ") -> (" <> pprint k2 <> text ")"
hunk ./FrontEnd/Tc/Kind.hs 124
-   pprint (Kindvar s) = text $ 'k':show s
+   pprint Kindvar { kvarUniq = s } = text $ 'k':show s
hunk ./FrontEnd/Tc/Main.hs 22
+import FrontEnd.Tc.Kind
hunk ./FrontEnd/Tc/Main.hs 85
-    bs <- sequence [ newBox Star | _ <- as ]
+    bs <- sequence [ newBox kindStar | _ <- as ]
hunk ./FrontEnd/Tc/Main.hs 146
-    scrutinee <- newBox KFunRet
+    scrutinee <- newBox kindFunRet
hunk ./FrontEnd/Tc/Main.hs 197
-    arg <- newBox Star
-    arg2 <- newBox Star
-    ret <- newBox Star
+    arg <- newBox kindStar
+    arg2 <- newBox kindStar
+    ret <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 234
-            withMetaVars mv [Star,KFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) e (a `fn` b) rs
+            withMetaVars mv [kindStar,kindFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) e (a `fn` b) rs
hunk ./FrontEnd/Tc/Main.hs 277
-    v <- newVar Star
+    v <- newVar kindStar
hunk ./FrontEnd/Tc/Main.hs 289
-        v <- newBox Star
+        v <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 429
-    v <- newBox Star
+    v <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 435
-    --v <- newBox Star
+    --v <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 442
-    v <- newBox Star
+    v <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 491
-    mv <- newMetaVar Sigma Star
+    mv <- newMetaVar Sigma kindStar
hunk ./FrontEnd/Tc/Main.hs 520
-    ts <- sequence [newMetaVar Tau Star | _ <- bs]
+    ts <- sequence [newMetaVar Tau kindStar | _ <- bs]
hunk ./FrontEnd/Tc/Main.hs 590
-            tr <- newBox Star
+            tr <- newBox kindStar
hunk ./FrontEnd/Tc/Main.hs 612
-            v <- newMetaVar Tau Star
+            v <- newMetaVar Tau kindStar
hunk ./FrontEnd/Tc/Main.hs 654
-            withMetaVars mv [Star,KFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs
+            withMetaVars mv [kindStar,kindFunRet] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs
hunk ./FrontEnd/Tc/Main.hs 797
-    v <- newVar Star
+    v <- newVar kindStar
hunk ./FrontEnd/Tc/Main.hs 804
-    v <- newVar Star
+    v <- newVar kindStar
hunk ./FrontEnd/Tc/Module.hs 141
-             putStr $ PPrint.render $ pprint kindInfo}
+             putStrLn $ PPrint.render $ pprint kindInfo}
hunk ./FrontEnd/Tc/Monad.hs 255
-            nvs <- mapM newVar  (replicate num Star)
+            nvs <- mapM newVar  (replicate num kindStar)
hunk ./FrontEnd/Tc/Monad.hs 394
-    nvs <- mapM (newVar . id . metaKind) vs
+    nvs <- mapM (newVar . fixKind . metaKind) vs
hunk ./FrontEnd/Tc/Monad.hs 402
-fixKind KFunRet = Star
+fixKind (KBase KFunRet) = KBase Star
hunk ./FrontEnd/Tc/Type.hs 3
+    KBase(..),
hunk ./FrontEnd/Tc/Type.hs 12
+    kindStar,
+    kindFunRet,
+    kindUTuple,
hunk ./Interactive.hs 159
-kindShow Star = "*"
+kindShow (KBase b) = pprint b
hunk ./Interactive.hs 232
-    box <- newBox Star
+    box <- newBox kindFunRet
hunk ./data/PrimitiveOperators-in.hs 16
+import FrontEnd.Tc.Kind
hunk ./utils/op_process.prl 113
-    my $v = "$n = TCon (Tycon tc_$x Star)";
+    my $v = "$n = TCon (Tycon tc_$x kindStar)";
}
