[make type checker generalize terms properly
John Meacham <john@repetae.net>**20060212140343] hunk ./E/FromHs.hs 84
-tipe (TAp t1 t2) = eAp (tipe t1) (tipe t2)
-tipe (TArrow t1 t2) =  EPi (tVr 0 (tipe t1)) (tipe t2)
-tipe (TCon (Tycon n k)) =  ELit (LitCons n [] (kind k))
-tipe (TVar (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
-tipe (TGen _ (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
+tipe t = f t where
+    f (TAp t1 t2) = eAp (f t1) (f t2)
+    f (TArrow t1 t2) =  EPi (tVr 0 (f t1)) (f t2)
+    f (TCon (Tycon n k)) =  ELit (LitCons n [] (kind k))
+    f (TVar tv) = EVar (cvar tv)
+    f (TMetaVar mv) = cmvar mv
+    f (TGen _ (Tyvar _ n k _)) = EVar (tVr (lt n) (kind k))
+    f (TForAll vs (_ :=> t)) = foldr EPi (f t) (map cvar vs)
+    cvar (Tyvar _ n k _) = (tVr (lt n) (kind k))
+    cmvar MetaVar { metaKind = k } = tAbsurd (kind k)
hunk ./E/FromHs.hs 125
-    Just (Forall _ (_ :=> t)) = Map.lookup n assumps -- getAssump n
+    Identity (Forall _ (_ :=> t)) = Map.lookup n assumps -- getAssump n
hunk ./FrontEnd/Tc/Main.hs 298
+tiPat pl@(HsPLit HsChar {}) typ = boxyMatch tChar typ >> return (pl,mempty)
+tiPat pl@(HsPLit HsString {}) typ = boxyMatch tString typ >> return (pl,mempty)
+tiPat pl@(HsPLit HsInt {}) typ = do
+    unBox typ
+    addPreds [IsIn class_Num typ]
+    return (pl,mempty)
+tiPat pl@(HsPLit HsFrac {}) typ = do
+    unBox typ
+    addPreds [IsIn class_Fractional typ]
+    return (pl,mempty)
+
+{-
hunk ./FrontEnd/Tc/Main.hs 314
-
+-}
hunk ./FrontEnd/Tc/Main.hs 408
+tcPragmaDecl prule@HsPragmaRules { hsDeclFreeVars = vs, hsDeclLeftExpr = e1, hsDeclRightExpr = e2, hsDeclSrcLoc = sloc } =
+    withContext (locMsg sloc "in the RULES pragma" $ hsDeclString prule) ans where
+        ans = do
+            vs' <- mapM dv vs
+            tr <- newBox Star
+            let (vs,envs) = unzip vs'
+            localEnv (mconcat envs) $ do
+                     tcExpr e1 tr
+                     tcExpr e2 tr
+            mapM_ unBox vs
+            return [prule]
+        dv n = do
+            v <- newMetaVar Tau Star
+            let env = (Map.singleton (toName Val n) v)
+            addToCollectedEnv env
+            return (v,env)
hunk ./FrontEnd/Tc/Main.hs 456
-            b1 <- newBox Star
-            b2 <- newBox Star
-            varBind mv (b1 `fn` b2)
-            l' <- lam (p:ps) (b1 `fn` b2) rs
+            withMetaVars mv [Star,Star] (\ [a,b] -> a `fn` b) $ \ [a,b] -> lam (p:ps) (a `fn` b) rs
+            --b1 <- newBox Star
+            --b2 <- newBox Star
+            --varBind mv (b1 `fn` b2)
+            --l' <- lam (p:ps) (b1 `fn` b2) rs
hunk ./FrontEnd/Tc/Main.hs 462
-            return l'
+            --return l'
hunk ./FrontEnd/Tc/Main.hs 731
-tiProgram ::  [BindGroup] -> Tc [HsDecl]
-tiProgram bgs = f bgs [] mempty where
+tiProgram ::  [BindGroup] -> [HsDecl] -> Tc [HsDecl]
+tiProgram bgs es = f bgs [] mempty where
hunk ./FrontEnd/Tc/Main.hs 736
-    f [] rs _cenv = return rs
+    f [] rs _cenv = do
+        mapM_ tcPragmaDecl (filter isHsPragmaRules es)
+        return rs
hunk ./FrontEnd/Tc/Module.hs 222
-        ds <- tiProgram program
+        ds <- tiProgram program ds
hunk ./FrontEnd/Tc/Monad.hs 91
-localEnv te = local (tcCurrentEnv_u (te `Map.union`))
+localEnv te | isGood = local (tcCurrentEnv_u (te `Map.union`)) where
+    isGood = not $ any isBoxy (Map.elems te)
+localEnv te = fail $ "localEnv error!\n" ++ show te
hunk ./FrontEnd/Tc/Monad.hs 264
-skolomize (TForAll vs (_ :=> rho)) = return (vs,rho) 
+skolomize (TForAll vs (_ :=> rho)) = return (vs,rho)
hunk ./FrontEnd/Tc/Monad.hs 295
-    quantify (freeMetaVars r) [] r
+    fmvenv <- freeMetaVarsEnv
+    liftIO $ mapM_ (putStrLn . pprint) (Set.toList fmvenv)
+    quantify ([ v  | v <- freeMetaVars r, not $ v `Set.member` fmvenv ]) [] r
hunk ./FrontEnd/Tc/Monad.hs 299
+freeMetaVarsEnv :: Tc (Set.Set MetaVar)
+freeMetaVarsEnv = do
+    env <- asks tcCurrentEnv
+    xs <- flip mapM (Map.elems env)  $ \ x -> do
+        x <- flattenType x
+        return $ freeMetaVars x
+    return (Set.fromList $ concat xs)
hunk ./FrontEnd/Tc/Monad.hs 440
-    
+
hunk ./FrontEnd/Tc/Type.hs 182
-flattenMetaVars t = unVar UnVarOpt { openBoxes = False, failEmptyMetaVar = False } t
+--flattenMetaVars t = unVar UnVarOpt { openBoxes = False, failEmptyMetaVar = False } t
hunk ./FrontEnd/Tc/Type.hs 185
+-- flattenType t = do (t,_,_) <- unbox t ; return t
+
hunk ./FrontEnd/Tc/Unify.hs 22
-    s1 <- findType s1
-    s2 <- findType s2
+    --s1 <- findType s1
+    --s2 <- findType s2
hunk ./FrontEnd/Tc/Unify.hs 76
-    s1 <- findType s1
-    s2 <- findType s2
+    --s1 <- findType s1
+    --s2 <- findType s2