[remove Scheme, Assump, and a lot of support code for old typechecker
John Meacham <john@repetae.net>**20060407094648] hunk ./DataConstructors.hs 52
-import Type(typeToScheme)
hunk ./DataConstructors.hs 65
-    tipe' (TGen n (Tyvar { tyvarKind = k })) = return $  EVar (tVr ((n + 1) * 2 ) (kind k))
hunk ./DataConstructors.hs 390
-            Just (Forall _ (_ :=> ty)) = fmap typeToScheme $ Map.lookup dataConsName cm
+            Just (TForAll _ (_ :=> ty)) =  Map.lookup dataConsName cm
hunk ./E/FromHs.hs 91
-    f (TVar Tyvar { tyvarRef = Just {}, tyvarKind = k}) = tAbsurd (kind k)
hunk ./E/FromHs.hs 93
-    f (TGen _ (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
hunk ./E/FromHs.hs 97
-    cvar _ Tyvar { tyvarRef = Just {}, tyvarKind = k}= error $ "tyvar is metaref:" ++ prettyPrintType t
hunk ./E/FromHs.hs 133
-fromTyvar (Tyvar _ n k _) = tVr (toId n) (kind k)
+fromTyvar (Tyvar _ n k) = tVr (toId n) (kind k)
hunk ./E/FromHs.hs 164
+
+convertOneVal = tipe
+{-
hunk ./E/FromHs.hs 171
+convertOneVal (TForAll _ (_ :=> t)) = (mp EPi ts (tipe t)) where
+    mp fn (((Tyvar _ n k _)):rs) t = fn (tVr (toId n) (kind k)) (mp fn rs t)
+    mp _ [] t = t
+    ts = ctgen t
+    -}
hunk ./E/FromHs.hs 222
-    cClass classRecord =  concat [ method classRecord n | n :>: Forall _ (_ :=> t) <- classAssumps classRecord ]
+    cClass classRecord =  concat [ method classRecord n | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord ]
hunk ./E/FromHs.hs 251
-    cClass classRecord =  concat [ method classRecord n | n :>: _ <- classAssumps classRecord ]
+    cClass classRecord =  concat [ method classRecord n | (n,_) <- classAssumps classRecord ]
hunk ./E/FromHs.hs 282
-    cClass classRecord =  [ setProperty prop_METHOD $ tVr (toId n) (convertOneVal t) | n :>: t <- classAssumps classRecord ]
+    cClass classRecord =  [ setProperty prop_METHOD $ tVr (toId n) (convertOneVal t) | (n,t) <- classAssumps classRecord ]
hunk ./E/FromHs.hs 473
-            Left t' -> return $ foldl eAp (EVar (tv n)) (map tipe $ specialize t t')
+            -- Left t' -> return $ foldl eAp (EVar (tv n)) (map tipe $ specialize t t')
hunk ./E/FromHs.hs 582
-            cClass classRecord =  [ f n (toId n) (convertOneVal t) | n :>: t <- classAssumps classRecord ] where
+            cClass classRecord =  [ f n (toId n) (convertOneVal t) | (n,t) <- classAssumps classRecord ] where
hunk ./E/FromHs.hs 592
+{-
hunk ./E/FromHs.hs 619
+-}
hunk ./FrontEnd/Class.hs 88
+import FrontEnd.Tc.Type
hunk ./FrontEnd/Class.hs 94
+type Assump = (Name,Sigma)
hunk ./FrontEnd/Class.hs 136
-    classAssumps :: [Assump],
+    classAssumps :: [(Name,Sigma)],
hunk ./FrontEnd/Class.hs 225
+aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)]
+aHsTypeSigToAssumps kt sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where
+    Identity typ = hsQualTypeToSigma kt qualType
+
hunk ./FrontEnd/Class.hs 440
-toType (HsTyVar n, k) = TVar $ tyvar (toName TypeVal n) k Nothing
+toType (HsTyVar n, k) = TVar $ tyvar (toName TypeVal n) k
hunk ./FrontEnd/Class.hs 535
-   = newMethodName :>: instantiatedSig where
+   = (newMethodName,instantiatedSig) where
hunk ./FrontEnd/Class.hs 537
-    [sigFromClass] = [ s | n :>: s <- methodSigs, n == methodName]
+    [sigFromClass] = [ s | (n,s) <- methodSigs, n == methodName]
hunk ./FrontEnd/Class.hs 543
-   = (renamedMethodDecls,newMethodName :>: instantiatedSig) where
+   = (renamedMethodDecls,(newMethodName, instantiatedSig)) where
hunk ./FrontEnd/Class.hs 546
-    sigFromClass = case [ s | n :>: s <- methodSigs, n == methodName] of
+    sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of
hunk ./FrontEnd/Class.hs 557
-   = (renamedMethodDecls,newMethodName :>: sigFromClass) where
+   = (renamedMethodDecls,(newMethodName,sigFromClass)) where
hunk ./FrontEnd/Class.hs 560
-    sigFromClass = case [ s | n :>: s <- methodSigs, n == methodName] of
+    sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of
hunk ./FrontEnd/Class.hs 580
-newMethodSig' :: KindEnv -> Name -> HsContext -> Scheme -> HsType -> Scheme
+newMethodSig' :: KindEnv -> Name -> HsContext -> Sigma -> HsType -> Sigma
hunk ./FrontEnd/Class.hs 582
-   ((IsIn _ classArg:restContext) :=> t) = unQuantify qt'
+   TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt'
hunk ./FrontEnd/Class.hs 595
-   newQualType = everywhere (mkT at) $ quantify (tv qt) qt
-   at (Tyvar _ n k r) =  tyvar (updateName (++ foo) n) k r
+   newQualType = everywhere (mkT at) $ tForAll (tv qt) qt
+   at (Tyvar _ n k) =  tyvar (updateName (++ foo) n) k
hunk ./FrontEnd/DataConsAssump.hs 35
+import FrontEnd.Tc.Type
hunk ./FrontEnd/DataConsAssump.hs 37
-import Type                     (Types (..), quantify)
+import Type                     (Types (..))
hunk ./FrontEnd/DataConsAssump.hs 42
-dataConsEnv :: Module -> KindEnv -> [HsDecl] -> Map.Map Name Scheme
+dataConsEnv :: Module -> KindEnv -> [HsDecl] -> Map.Map Name Sigma
hunk ./FrontEnd/DataConsAssump.hs 50
-dataDeclEnv :: Module -> KindEnv -> (HsDecl) -> Map.Map Name Scheme
+dataDeclEnv :: Module -> KindEnv -> (HsDecl) -> Map.Map Name Sigma
hunk ./FrontEnd/DataConsAssump.hs 62
-      = TVar (tyvar (toName TypeVal n) k Nothing)
+      = TVar (tyvar (toName TypeVal n) k)
hunk ./FrontEnd/DataConsAssump.hs 76
-      = TVar (tyvar (toName TypeVal n) k Nothing)
+      = TVar (tyvar (toName TypeVal n) k)
hunk ./FrontEnd/DataConsAssump.hs 86
+-- XXX we ignore predicates on data constructors because they don't mean anything
hunk ./FrontEnd/DataConsAssump.hs 88
-conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Map.Map Name Scheme
+conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Map.Map Name Sigma
hunk ./FrontEnd/DataConsAssump.hs 90
-   = Map.singleton (toName DataConstructor conName) $ quantify (tv qualConType) qualConType
+   = Map.singleton (toName DataConstructor conName) $ tForAll (tv qualConType) qualConType
hunk ./FrontEnd/DataConsAssump.hs 95
-   = Map.singleton (toName DataConstructor conName) $ quantify (tv qualConType) qualConType
+   = Map.singleton (toName DataConstructor conName) $ tForAll (tv qualConType) qualConType
hunk ./FrontEnd/KindInfer.hs 10
-    hsQualTypeToScheme,
hunk ./FrontEnd/KindInfer.hs 41
-import Type(quantify,tv,tTTuple,schemeToType,typeToScheme)
+import Type(tTTuple)
hunk ./FrontEnd/KindInfer.hs 533
---aHsTypeToType kt (HsTyForall vs qt) = TForAll map (kindOf (aHsQualTypeToScheme kt qt)
hunk ./FrontEnd/KindInfer.hs 538
-toTyvar kt name =  tyvar  nn (kindOf nn kt) Nothing where
+toTyvar kt name =  tyvar  nn (kindOf nn kt) where
hunk ./FrontEnd/KindInfer.hs 549
-   | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt) Nothing)
+   | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt))
hunk ./FrontEnd/KindInfer.hs 551
-hsQualTypeToScheme :: Monad m => KindEnv -> HsQualType -> m Scheme
-hsQualTypeToScheme kt qualType = liftM typeToScheme $ hsQualTypeToSigma kt qualType
hunk ./FrontEnd/KindInfer.hs 578
-    f t@TGen {} = t
hunk ./FrontEnd/Representation.hs 25
-    findType,
hunk ./FrontEnd/Representation.hs 28
-    flattenType,
-    Scheme(..),
-    FlattenType(..),
-    Assump(..),
hunk ./FrontEnd/Representation.hs 40
-import Text.PrettyPrint.HughesPJ(nest,Doc)
+import Text.PrettyPrint.HughesPJ(Doc)
hunk ./FrontEnd/Representation.hs 66
-           | TGen { typeSeq :: {-# UNPACK #-} !Int, typeVar :: {-# UNPACK #-} !Tyvar }
hunk ./FrontEnd/Representation.hs 99
-    (TGen a _) == (TGen b _) = a == b
hunk ./FrontEnd/Representation.hs 105
-data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName ::  !Name, tyvarKind :: Kind, tyvarRef :: Maybe (IORef (Maybe Type)) }
+data Tyvar = Tyvar { tyvarAtom :: {-# UNPACK #-} !Atom, tyvarName ::  !Name, tyvarKind :: Kind }
hunk ./FrontEnd/Representation.hs 110
-    showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k, tyvarRef = Just _ } = shows hn . (":-" ++) . shows k
hunk ./FrontEnd/Representation.hs 120
-findType :: MonadIO m => Type -> m Type
-findType tv@(TVar Tyvar {tyvarRef = Just r }) = liftIO $ do
-    rt <- readIORef r
-    case rt of
-        Nothing -> return tv
-        Just t -> do
-            t' <- findType t
-            writeIORef r (Just t')
-            return t'
-findType tv = return tv
-
-refType (TVar tv@Tyvar {tyvarRef = Nothing}) = do
-    r <- newIORef Nothing
-    return $ TVar tv { tyvarRef = Just r }
-refType t = return t
-
-unrefType (TVar tv) =  TVar tv { tyvarRef = Nothing }
-unrefType t = t
-
-
-class FlattenType t where
-    flattenType' ::  t -> IO t
-
-flattenType :: (FlattenType t, MonadIO m) => t -> m t
-flattenType t = liftIO (flattenType' t)
-
-instance FlattenType t => FlattenType [t] where
-   flattenType' xs = mapM flattenType' xs
-
-instance FlattenType Pred where
-    flattenType' (IsIn c t) = do
-        t' <- flattenType' t
-        return $ IsIn c t'
-
-instance FlattenType t => FlattenType (Qual t) where
-    flattenType' (ps :=> t) = do
-        ps' <- flattenType' ps
-        t' <- flattenType' t
-        return $ ps' :=> t'
-
-instance FlattenType Type where
-    flattenType' tv =  do
-        tv' <- findType tv
-        let ft (TAp x y) = do
-                x' <- flattenType' x
-                y' <- flattenType' y
-                return $ TAp x' y'
-            ft (TArrow x y) = do
-                x' <- flattenType' x
-                y' <- flattenType' y
-                return $ TArrow x' y'
-            ft (TForAll vs qt) = do
-                qt' <- flattenType' qt
-                return $ TForAll vs qt'
-            ft (TExists vs qt) = do
-                qt' <- flattenType' qt
-                return $ TExists vs qt'
-            ft t = return t
-        ft tv'
-
-instance FlattenType Scheme where
-    flattenType' (Forall ks qt) = flattenType' qt >>= return . Forall ks
-
-instance FlattenType Assump where
-    flattenType' (ks :>: qt) = flattenType' qt >>= return . (:>:) ks
-
-instance FlattenType t => FlattenType (Map.Map x t) where
-    flattenType' mp = sequence [flattenType' y >>= return . (,) x| (x,y) <- Map.toAscList mp] >>= return . Map.fromDistinctAscList
hunk ./FrontEnd/Representation.hs 149
-instance ToTuple Scheme where
-    toTuple n = Forall [] ([] :=> toTuple n)
hunk ./FrontEnd/Representation.hs 177
-           TGen _ (Tyvar { tyvarName = tv })   -> do
-                            findResult <- lookupInMap t
-                            case findResult of
-                                Nothing -> do
-                                    nm <- nextName
-                                    updateVMap (t, nm)
-                                    return (text nm)
-                                    --return (text nm <> parens (text (show tv)))
-                                Just v  -> return $ text v <> tyvar (text (show tv))
hunk ./FrontEnd/Representation.hs 222
-newtype Kindvar = Kindvar Int deriving(Data, Binary,Typeable, Ord, Eq, Show)
+newtype Kindvar = Kindvar Int deriving
+    (Data,Binary,Typeable,Ord,Eq,Show)
hunk ./FrontEnd/Representation.hs 324
--- schemes
-
-
-data Scheme = Forall [Kind] (Qual Type)
-              deriving(Data,Typeable, Eq, Show, Ord)
-    {-! derive: GhcBinary !-}
-
-instance PPrint Doc Scheme where
-  pprint scheme
-    = fst $ runVarName [] nameSupply $ prettyPrintSchemeM scheme
-
-prettyPrintSchemeM :: Scheme -> VarName Doc
-prettyPrintSchemeM (Forall _kinds qType) = do
-    r <- prettyPrintQualTypeM qType
-    return r
hunk ./FrontEnd/Representation.hs 327
--- assumptions
-
-data Assump =  (:>:) Name Scheme
-    deriving(Ord,Eq,Data,Typeable, Show)
-    {-! derive: GhcBinary !-}
hunk ./FrontEnd/Representation.hs 328
-instance  PPrint Doc Assump where
-  pprint (i :>: s) = (text (show i) <+> text ":>:") <$> nest 2 (pprint s)
hunk ./FrontEnd/Representation.hs 385
-    put_ bh (Tyvar aa ab ac ad) = do
+    put_ bh (Tyvar aa ab ac) = do
hunk ./FrontEnd/Representation.hs 396
-    return (Tyvar aa ab ac Nothing)
+    return (Tyvar aa ab ac)
hunk ./FrontEnd/Tc/Class.hs 81
-       hnf TGen {} = False
hunk ./FrontEnd/Tc/Module.hs 138
-    let localDConsEnv = Map.map schemeToType $ dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
+    let localDConsEnv =  dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
hunk ./FrontEnd/Tc/Module.hs 163
-        instanceEnv   = Map.fromList $ [ (x,y) | (x :>: y) <-  instAssumps ]
+        instanceEnv   = Map.fromList instAssumps
hunk ./FrontEnd/Tc/Module.hs 165
-        classEnv  = Map.fromList $ [ (x,y) | (x :>: y) <- myClassAssumps, x `elem` classDefs  ]
+        classEnv  = Map.fromList $ [ (x,y) | (x,y) <- myClassAssumps, x `elem` classDefs  ]
hunk ./FrontEnd/Tc/Module.hs 192
-        noDefaultSigs = Map.fromList [ (n,schemeToType $ maybe (error $ "sigEnv:"  ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]
+        noDefaultSigs = Map.fromList [ (n,maybe (error $ "sigEnv:"  ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]
hunk ./FrontEnd/Tc/Module.hs 201
-    let program = makeProgram (Map.map schemeToType sigEnv) programBgs
+    let program = makeProgram sigEnv programBgs
hunk ./FrontEnd/Tc/Module.hs 214
-        tcInfoSigEnv = Map.map schemeToType $ sigEnv ,
+        tcInfoSigEnv = sigEnv,
hunk ./FrontEnd/Tc/Monad.hs 256
-    inst mm ts (TVar tv )
-        | Nothing == tyvarRef tv  = case Map.lookup (tyvarAtom tv) ts of
+    inst mm ts (TVar tv ) = case Map.lookup (tyvarAtom tv) ts of
hunk ./FrontEnd/Tc/Monad.hs 298
-        v = tyvar ident k Nothing
+        v = tyvar ident k
hunk ./FrontEnd/Tc/Type.hs 29
-import Representation hiding(flattenType, findType)
+import Representation
hunk ./FrontEnd/Type.hs 31
-             mgu,
-             match,
-             quantify,
-             unQuantify,
-             toScheme,
-             makeAssump,
-             assumpScheme,
-             assumpToPair,
-             pairToAssump,
hunk ./FrontEnd/Type.hs 32
-             assumpId,
-             tTTuple,
-             schemeToType,
-             typeToScheme,
-             Instantiate (..)
+             match,
+             tTTuple
hunk ./FrontEnd/Type.hs 54
-class Instantiate t where
-  inst  :: [Type] -> t -> t
-
-instance Instantiate Type where
-  inst ts (TAp l r)     = TAp (inst ts l) (inst ts r)
-  inst ts (TArrow l r)  = TArrow (inst ts l) (inst ts r)
-  inst ts t@(TGen n _)  | n < length ts = ts !! n
-                        | otherwise = error $ "inst TGen " ++ show (ts,t)
-  inst ts t             = t
-
-instance Instantiate a => Instantiate [a] where
-  inst ts = map (inst ts)
-
-instance Instantiate t => Instantiate (Qual t) where
-  inst ts (ps :=> t) = inst ts ps :=> inst ts t
-
-instance Instantiate Pred where
-  inst ts (IsIn c t) = IsIn c (inst ts t)
hunk ./FrontEnd/Type.hs 61
+
hunk ./FrontEnd/Type.hs 69
-  kind (TGen _ tv) = kind tv
hunk ./FrontEnd/Type.hs 135
+{-
hunk ./FrontEnd/Type.hs 189
+            -}
+
hunk ./FrontEnd/Type.hs 218
------------------------------------------------------------------------------
-
-instance Types Scheme where
-  apply s (Forall ks qt) = Forall ks (apply s qt)
-  tv (Forall ks qt)      = tv qt
-
-quantify      :: [Tyvar] -> Qual Type -> Scheme
-quantify vs qt = Forall ks (apply s qt)
- where vs' = [ v | v <- tv qt, v `elem` vs ]
-       ks  = map kind vs'
-       s   = Map.fromList $ map (\(a,b) -> (a,b a)) $ zip vs' (map TGen [0..])
-
-toScheme      :: Type -> Scheme
-toScheme t     = Forall [] ([] :=> t)
-
-unQuantify :: Scheme -> (Qual Type)
-unQuantify (Forall _ (ps :=> t)) =  map uq' ps :=> uq t where
-    uq (TAp a b) = TAp (uq a) (uq b)
-    uq (TArrow a b) = TArrow (uq a) (uq b)
-    uq (TGen _ tv) = TVar tv
-    uq x = x
-    uq' (IsIn s t) = IsIn s (uq t)
-
-schemeToType :: Scheme -> Type
-schemeToType (Forall _ (ps :=> t)) = tForAll ( snds $ snubFst xs) (ps' :=> t') where
-    ((ps',t'),xs) = runWriter $ do
-        ps' <- mapM uq' ps
-        t' <- uq t
-        return (ps',t')
-    uq (TAp a b) = liftM2 TAp (uq a) (uq b)
-    uq (TArrow a b) = liftM2 TArrow (uq a) (uq b)
-    uq (TGen n tv) = do
-        tell [(n,tv)]
-        return $ TVar tv
-    uq (TForAll xs (ps :=> t)) = do
-        ps' <- mapM uq' ps
-        t' <- uq t
-        return $ tForAll xs (ps' :=> t')
-    uq x = return x
-    uq' (IsIn s t) = liftM (IsIn s) (uq t)
-
-typeToScheme :: Type -> Scheme
-typeToScheme (TForAll as qt) = quantify as qt
-typeToScheme t = toScheme t
------------------------------------------------------------------------------
-
-assumpToPair :: Assump -> (Name, Scheme)
-assumpToPair (n :>: s) = (n,s)
-
-pairToAssump :: (Name, Scheme) -> Assump
-pairToAssump (n,s) = (n :>: s)
-
-instance Types Assump where
-  apply s (i :>: sc) = i :>: (apply s sc)
-  tv (i :>: sc)      = tv sc
-
-
-assumpId :: Assump -> Name
-assumpId (id :>: _scheme) = id
hunk ./FrontEnd/Type.hs 219
-assumpScheme :: Assump -> Scheme
-assumpScheme (_id :>: scheme) = scheme
hunk ./FrontEnd/Type.hs 220
-makeAssump :: Name -> Scheme -> Assump
-makeAssump name scheme = name :>: scheme
hunk ./FrontEnd/TypeSigs.hs 20
+import Control.Monad.Identity
hunk ./FrontEnd/TypeSigs.hs 22
-import Type(assumpToPair)
-import FrontEnd.KindInfer(KindEnv)
-import Representation(Scheme)
-import TypeUtils(aHsTypeSigToAssumps)
+import FrontEnd.KindInfer
hunk ./FrontEnd/TypeSigs.hs 24
+import FrontEnd.Tc.Type
hunk ./FrontEnd/TypeSigs.hs 202
-type SigEnv = Map.Map Name Scheme
+type SigEnv = Map.Map Name Type
hunk ./FrontEnd/TypeSigs.hs 206
-   = Map.fromList $
-        map assumpToPair $
-        concatMap (aHsTypeSigToAssumps kt) sigs
+   = Map.fromList $ concatMap (aHsTypeSigToAssumps kt) sigs
hunk ./FrontEnd/TypeSigs.hs 208
+aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)]
+aHsTypeSigToAssumps kt sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where
+    Identity typ = hsQualTypeToSigma kt qualType
hunk ./FrontEnd/TypeUtils.hs 18
-module TypeUtils (aHsTypeSigToAssumps,flattenLeftTypeApplication) where
+module TypeUtils (flattenLeftTypeApplication) where
hunk ./FrontEnd/TypeUtils.hs 22
-
-import Type                     (tv,
-                                 quantify,
-                                 makeAssump,
-                                 assumpScheme,
-                                 tTTuple,
-                                 assumpId)
-
+import Type           (tv,tTTuple)
hunk ./FrontEnd/TypeUtils.hs 50
+{-
hunk ./FrontEnd/TypeUtils.hs 57
-{-
hunk ./Interactive.hs 41
-import Representation hiding(flattenType)
+import Representation
hunk ./Interactive.hs 43
-import Type(schemeToType)
hunk ./Interactive.hs 225
-        tcInfoSigEnv = Map.map schemeToType $ collectSigEnv (hoKinds ho) (HsQualifier e),
+        tcInfoSigEnv =  collectSigEnv (hoKinds ho) (HsQualifier e),