[add ability for subsumption checking to return a coercion term
John Meacham <john@repetae.net>**20060228131603] hunk ./FrontEnd/Tc/Monad.hs 2
+    CoerceTerm(..),
hunk ./FrontEnd/Tc/Monad.hs 6
+    addCoerce,
hunk ./FrontEnd/Tc/Monad.hs 8
+    composeCoerce,
hunk ./FrontEnd/Tc/Monad.hs 19
+    getCollectedCoerce,
hunk ./FrontEnd/Tc/Monad.hs 83
+    tcCollectedCoerce   :: IORef (Map.Map Name CoerceTerm),
hunk ./FrontEnd/Tc/Monad.hs 110
+--data Coerce e = CoerceJust e | CoerceLam [Tyvar] (Coerce e) | CoerceApp (Coerce e) [Type] | CoerceFn (Coerce e -> Coerce e) (Coerce e)
+
+--newtype CoerceTerm = CoerceTerm (forall e . Coerce e -> Coerce e)
+
+
+
hunk ./FrontEnd/Tc/Monad.hs 132
+addCoerce :: Name -> CoerceTerm -> Tc ()
+addCoerce n te = do
+    v <- asks tcCollectedCoerce
+    liftIO $ modifyIORef v (Map.insert n te)
+
hunk ./FrontEnd/Tc/Monad.hs 144
+getCollectedCoerce :: Tc (Map.Map Name CoerceTerm)
+getCollectedCoerce = do
+    v <- asks tcCollectedCoerce
+    r <- liftIO $ readIORef v
+    --r <- fmapM flattenType r
+    return r
+
hunk ./FrontEnd/Tc/Monad.hs 158
+    cc <- newIORef mempty
hunk ./FrontEnd/Tc/Monad.hs 161
+        tcCollectedCoerce = cc,
hunk ./FrontEnd/Tc/Monad.hs 273
-freshInstance :: MetaVarType -> Sigma -> Tc Rho
+freshInstance :: MetaVarType -> Sigma -> Tc ([Type],Rho)
hunk ./FrontEnd/Tc/Monad.hs 278
-    return t
-freshInstance _ x = return x
+    return (ts,t)
+freshInstance _ x = return ([],x)
hunk ./FrontEnd/Tc/Monad.hs 320
-boxyInstantiate :: Sigma -> Tc Rho'
+boxyInstantiate :: Sigma -> Tc ([Type],Rho')
hunk ./FrontEnd/Tc/Monad.hs 330
-    freshInstance Sigma (TForAll (vs List.\\ eqvs) qt)
+    (_,t) <- freshInstance Sigma (TForAll (vs List.\\ eqvs) qt)
+    return t
hunk ./FrontEnd/Tc/Type.hs 337
+
+-- CTFun f => \g . \y -> f (g y)
+data CoerceTerm = CTId | CTAp [Type] | CTAbs [Tyvar] | CTFun CoerceTerm | CTCompose CoerceTerm CoerceTerm
+
+composeCoerce :: CoerceTerm -> CoerceTerm -> CoerceTerm
+composeCoerce CTId x = x
+composeCoerce x CTId = x
+composeCoerce x y = CTCompose x y
+
+
+instance UnVar Type => UnVar CoerceTerm where
+    unVar' opt (CTAp ts) = CTAp `liftM` unVar' opt ts
+    unVar' opt (CTFun ct) = CTFun `liftM` unVar' opt ct
+    unVar' opt (CTCompose c1 c2) = liftM2 CTCompose (unVar' opt c1) (unVar' opt c2)
+    unVar' _ x = return x
+
+
+
hunk ./FrontEnd/Tc/Unify.hs 17
+
+ctId = CTId
+
+
hunk ./FrontEnd/Tc/Unify.hs 28
-subsumes :: Sigma' -> Sigma' -> Tc ()
+subsumes :: Sigma' -> Sigma' -> Tc CoerceTerm
hunk ./FrontEnd/Tc/Unify.hs 42
-    sub tb@(TMetaVar mv) b  = boxyMatch tb b
+    sub tb@(TMetaVar mv) b  = do
+        boxyMatch tb b
+        return ctId
hunk ./FrontEnd/Tc/Unify.hs 49
-        (_,_,r2) <- skolomize fa
-        s1 `subsumes` r2
+        (vs,_,r2) <- skolomize fa
+        f <- s1 `subsumes` r2
+        return (composeCoerce (CTAbs vs) f)
+        --return (CoerceTerm (\x -> CoerceLam vs (f x)))
hunk ./FrontEnd/Tc/Unify.hs 57
-        r1' <- boxyInstantiate s1
-        r1' `subsumes` r2
+        (ts,r1') <- boxyInstantiate s1
+        f <- r1' `subsumes` r2
+        return (f `composeCoerce` (CTAp ts))
+        --return (CoerceTerm (\x -> f (CoerceApp x ts)))
hunk ./FrontEnd/Tc/Unify.hs 63
-    sub s1 s2 | (_,(_:_)) <- fromTAp s1 = s1 `boxyMatch` s2
-
-   -- sub s1 (TMetaVar mv) | (t,ts@(_:_)) <- fromTAp s1 = do
-   --     let ats = t:ts
-   --     withMetaVars mv (map getaType ats) (map  (\ (t:ts) -> TArrow a b) $ \ [a,b] -> do
-   --     subsumes t (a `fn` b)
-
+    sub s1 s2 | (_,(_:_)) <- fromTAp s1 = do
+        s1 `boxyMatch` s2
+        return ctId
hunk ./FrontEnd/Tc/Unify.hs 71
-        s2 `subsumes` s4
+        f2 <- s2 `subsumes` s4
+        return (CTFun f2)
+        --return (CoerceTerm (\g -> CoerceFn f2 g))
+        --return (\g y -> f2 (runCoerce g y))
+
hunk ./FrontEnd/Tc/Unify.hs 83
-    sub a (TMetaVar mv) | isTau a  = varBind mv a
+    sub a (TMetaVar mv) | isTau a  = varBind mv a >> return ctId
hunk ./FrontEnd/Tc/Unify.hs 85
-    sub a b | isTau a && isTau b = unify a b
+    sub a b | isTau a && isTau b = unify a b >> return ctId
hunk ./FrontEnd/TiData.hs 14
-    tiDataModules :: [(Module,HsModule)],
-    tiModuleOptions :: [(Module,Opt)],
-    tiCheckedRules :: [Rule],
+    tiDataModules    :: [(Module,HsModule)],
+    tiModuleOptions  :: [(Module,Opt)],
+    tiCheckedRules   :: [Rule],
+    tiCoerce         :: Map.Map Name CoerceTerm,