[add a lot of new support functions to FrontEnd.Tc.Type. stop relying on buggy ones in FrontEnd.Representation. distinguish MetaVars and Tyvars more
John Meacham <john@repetae.net>**20051210035421] hunk ./FrontEnd/Representation.hs 275
-instance PPrint Doc Tycon where
+instance DocLike d => PPrint d Tycon where
hunk ./FrontEnd/Tc/Main.hs 26
-import Representation
+--import Representation
hunk ./FrontEnd/Tc/Main.hs 156
+--tiExpr env tuple@(HsTuple exps@(_:_)) typ = withContext (makeMsg "in the tuple" $ render $ ppHsExp tuple) $ do
+--    psasts <- mapM tiExpr exps
+--    let typeList = map trd3 psasts
+--    let preds = concatMap fst3 psasts
+--    let env1 = Map.unions $ map snd3 psasts
+--    return (preds, env1, tTTuple typeList)
+
+
hunk ./FrontEnd/Tc/Main.hs 198
+    addToCollectedEnv $ (Map.singleton (toName Val x) rr)
hunk ./FrontEnd/Tc/Main.hs 227
+tiPat (HsPIrrPat p) typ = tiPat p typ
+tiPat (HsPParen p) typ = tiPat p typ
+
hunk ./FrontEnd/Tc/Main.hs 262
-tiPat (HsPIrrPat p) = tiPat p
-
-tiPat (HsPParen p) = tiPat p
hunk ./FrontEnd/Tc/Monad.hs 48
-import Representation
-import Type(tv)
hunk ./FrontEnd/Tc/Monad.hs 170
-    return (liftIO $ readIORef r >>= flattenType, TBox k u r)
+    return (liftIO $ readIORef r >>= flattenMetaVars, TBox k u r)
hunk ./FrontEnd/Tc/Monad.hs 348
-    let mtvs = (filter isMetaTV (tv r))
+    let mtvs = freeMetaVars r
hunk ./FrontEnd/Tc/Monad.hs 351
-    freshSigma (tForAll nvs ([] :=> r))
+    r <- flattenMetaVars r
+    return $ TForAll nvs ([] :=> r)
hunk ./FrontEnd/Tc/Monad.hs 357
-            | u `elem` tv t = fail "varBind: occurs check fails"
+            | u `elem` freeMetaVars t = fail "varBind: occurs check fails"
hunk ./FrontEnd/Tc/Type.hs 2
-    module FrontEnd.Tc.Type,
-    Type(..),
-    Kind(..),
hunk ./FrontEnd/Tc/Type.hs 4
+    kind,
+    Kind(..),
+    Sigma(),
+    Pred(..),
+    Tau(),
+    Rho(),
+    tForAll,
+    module FrontEnd.Tc.Type,
hunk ./FrontEnd/Tc/Type.hs 13
-    Tyvar(..),
hunk ./FrontEnd/Tc/Type.hs 14
-    tv,
-    kind
+    Type(..),
+    tyvar,
+    tList,
+    Tyvar(..)
hunk ./FrontEnd/Tc/Type.hs 20
-import Control.Monad.Trans
hunk ./FrontEnd/Tc/Type.hs 21
+import List
hunk ./FrontEnd/Tc/Type.hs 24
+import Doc.DocLike
+import Util.VarName
+import Unparse
+import Doc.PPrint
hunk ./FrontEnd/Tc/Type.hs 29
-import Type(kind,tv)
+import Type(kind)
hunk ./FrontEnd/Tc/Type.hs 84
+extractMetaTV :: Monad m => Type -> m MetaTV
+extractMetaTV (TVar t) | isMetaTV t = return t
+extractMetaTV t = fail $ "not a metaTyVar:" ++ prettyPrintType t
+
+extractTyVar ::  Monad m => Type -> m Tyvar
+extractTyVar (TVar t) | not $ isMetaTV t = return t
+extractTyVar t = fail $ "not a Var:" ++ prettyPrintType t
+
+
+prettyPrintType :: DocLike d => Type -> d
+prettyPrintType t  = unparse $ runVarName (f t) where
+    arr = bop (R,0) (space <> text "->" <> space)
+    app = bop (L,100) (text " ")
+--    fp :: DocLike d => Pred -> VarName Atom Char (Unparse d)
+    fp (IsIn cn t) = do
+        t' <- f t
+        return (atom (text $ show cn) `app` t')
+--    f :: DocLike d => Type -> VarName Atom Char (Unparse d)
+    f (TForAll vs (ps :=> t)) = do
+        ts' <- mapM (newLookupName ['a'..] ()) vs
+        t' <- f t
+        ps' <- mapM fp ps
+        return $ fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". " <> if null ps then empty else tupled (map unparse ps') <+> text "=> ")  (atomize t')
+    f (TCon tycon) = return $ atom (pprint tycon)
+    f (TVar tyvar) = do
+        vo <- newLookupName ['a' .. ] () tyvar
+        return $ atom $ char vo
+           -- check for the Prelude.[] special case
+    f (TAp t1 t2) = do
+        t1 <- f t1
+        t2 <- f t2
+        return $ t1 `app` t2
+    f (TArrow t1 t2) = do
+        t1 <- f t1
+        t2 <- f t2
+        return $ t1 `arr` t2
+    f (TBox Star i _) = return $ atom $ text "_" <> tshow i
+    f t | ~(TBox k i _) <- t = return $ atom $ parens $ text "_" <> tshow i <> text " :: " <> pprint k
+
+
+
+data UnVarOpt = UnVarOpt {
+    openBoxes :: Bool,
+    failEmptyMetaVar :: Bool
+    }
+
+flattenMetaVars t = unVar UnVarOpt { openBoxes = False, failEmptyMetaVar = False } t
+flattenType t =  unVar UnVarOpt { openBoxes = True, failEmptyMetaVar = False } t
+
+
+class UnVar t where
+    unVar' ::  UnVarOpt -> t -> IO t
+
+unVar :: (UnVar t, MonadIO m) => UnVarOpt -> t -> m t
+unVar opt t = liftIO (unVar' opt t)
+
+instance UnVar t => UnVar [t] where
+   unVar' opt xs = mapM (unVar' opt) xs
+
+instance UnVar Pred where
+    unVar' opt (IsIn c t) = IsIn c `liftM` unVar' opt t
+
+instance UnVar t => UnVar (Qual t) where
+    unVar' opt (ps :=> t) = liftM2 (:=>) (unVar' opt ps) (unVar' opt t)
+
+instance UnVar Type where
+    unVar' opt tv =  do
+        let ft (TAp x y) = liftM2 TAp (unVar' opt x) (unVar' opt y)
+            ft (TArrow x y) = liftM2 TArrow (unVar' opt x) (unVar' opt y)
+            ft t@TCon {} = return t
+            ft (TForAll vs qt) = do
+                when (any isMetaTV vs) $ error "metatv in forall binding"
+                qt' <- unVar' opt qt
+                return $ TForAll vs qt'
+            ft t@TBox { typeBox = box }
+                | openBoxes opt =  readIORef box >>= unVar' opt
+                | otherwise = return t
+            ft t | Just tv <- extractMetaTV t = if failEmptyMetaVar opt then fail $ "empty meta var" ++ prettyPrintType t else return (TVar tv)
+            ft t | ~(Just tv) <- extractTyVar t  = return (TVar tv)
+        tv' <- findType tv
+        ft tv'
+
+
+
+freeMetaVars :: Type -> [MetaTV]
+freeMetaVars t = filter isMetaTV $ allFreeVars t
+
+freeTyVars :: Type -> [Tyvar]
+freeTyVars t = filter (not . isMetaTV) $ allFreeVars t
+
+allFreeVars (TVar u)      = [u]
+allFreeVars (TAp l r)     = allFreeVars l `union` allFreeVars r
+allFreeVars (TArrow l r)  = allFreeVars l `union` allFreeVars r
+allFreeVars TCon {}       = []
+allFreeVars TBox {}       = []
+allFreeVars typ | ~(TForAll vs (_ :=> t)) <- typ = allFreeVars t List.\\ vs
+
+
hunk ./FrontEnd/Tc/Unify.hs 12
-import Data.IORef
hunk ./FrontEnd/Tc/Unify.hs 26
-    sub (TArrow a b) (TVar t) | isMetaTV t = do
+    sub (TArrow a b) t | Just t <- extractMetaTV t = do
hunk ./FrontEnd/Tc/Unify.hs 31
-    sub (TAp a b) (TVar t) | isMetaTV t = do
+    sub (TAp a b) t | Just t <- extractMetaTV t = do
hunk ./FrontEnd/Tc/Unify.hs 155
-    bm (TArrow a b) (TVar t) | isMetaTV t = do
+    bm (TArrow a b) t | Just t <- extractMetaTV t = do
hunk ./FrontEnd/Tc/Unify.hs 161
-    bm (TAp a b) (TVar t) | isMetaTV t = do
+    bm (TAp a b) t | Just t <- extractMetaTV t = do
hunk ./Interactive.hs 28
+import FrontEnd.Tc.Type
hunk ./Interactive.hs 39
-import Representation
+import Representation hiding(flattenType)
hunk ./Interactive.hs 41
-import Type(schemeToType,quantify,tv)
+import Type(schemeToType)
hunk ./Interactive.hs 222
-    qt <- flattenType (ps :=> vv)
-    let vv' = quantify (tv vv) qt
-    liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)
+    (ps :=> vv) <- flattenType (ps :=> vv)
+    TForAll vs ([] :=> t) <- generalize vv -- quantify (tv vv) qt
+    --liftIO $ putStrLn $ show (text "::" <+> pprint vv' :: P.Doc)
+    liftIO $ putStrLn $   "::" <+> prettyPrintType (TForAll vs (ps :=> t))
hunk ./Util/VarName.hs 3
+    VarName(),