[commit: ghc] supercompiler: Support for LitTy in Match/MSG (69a6dcf)
Max Bolingbroke <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/69a6dcf0aafa0da02e41b92d032a58a2bc4b3384 >--------------------------------------------------------------- commit 69a6dcf0aafa0da02e41b92d032a58a2bc4b3384 Author: Max Bolingbroke <[email protected]> Date: Fri May 11 08:39:52 2012 +0100 Support for LitTy in Match/MSG >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 2 ++ compiler/supercompile/Supercompile/Drive/Match.hs | 1 + 2 files changed, 3 insertions(+), 0 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 87a55f6..2a8b0f4 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -639,6 +639,7 @@ canAbstractOverTyVarOfKind = ok ok (TyConApp _ ks) = all ok ks ok (FunTy k1 k2) = ok k1 && ok k2 ok (ForAllTy _ k) = ok k + ok (LitTy _) = True -- NB: we don't match FunTy and TyConApp literally because -- we can do better MSG for combinations like: @@ -676,6 +677,7 @@ msgType' _ _ (TyConApp tc_l []) (TyConApp tc_r []) | tc_l == tc_ msgType' are_kinds rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) | not (null tys_l) || not (null tys_r) = msgType' are_kinds rn2 (foldl AppTy (TyConApp tc_l []) tys_l) (foldl AppTy (TyConApp tc_r []) tys_r) msgType' are_kinds rn2 (FunTy ty1_l ty2_l) (FunTy ty1_r ty2_r) = msgType' are_kinds rn2 ((TyConApp funTyCon [] `AppTy` ty1_l) `AppTy` ty2_l) ((TyConApp funTyCon [] `AppTy` ty1_r) `AppTy` ty2_r) msgType' are_kinds rn2 (ForAllTy a_l ty_l) (ForAllTy a_r ty_r) = msgTyVarBndr ForAllTy rn2 a_l a_r $ \rn2 -> msgType' are_kinds rn2 ty_l ty_r +msgType' _ _ (LitTy l_l) (LitTy l_r) | l_l == l_r = return (LitTy l_r) msgType' are_kinds rn2 ty_l ty_r | are_kinds = fail "msgType: no generalisation at kind level" | not (canAbstractOverTyVarOfKind (typeKind ty_l')) = fail "msgType: bad kind for type generalisation" -- NB: legit to just check left hand side because kinds are ungeneralised, so it will eventualy be checked that it exactly matches the right diff --git a/compiler/supercompile/Supercompile/Drive/Match.hs b/compiler/supercompile/Supercompile/Drive/Match.hs index cade7f7..7d754f6 100644 --- a/compiler/supercompile/Supercompile/Drive/Match.hs +++ b/compiler/supercompile/Supercompile/Drive/Match.hs @@ -179,6 +179,7 @@ matchType rn2 (AppTy ty1_l ty2_l) (AppTy ty1_r ty2_r) = liftM2 (++) (matchTy matchType rn2 (TyConApp tc_l tys_l) (TyConApp tc_r tys_r) = guard "matchType: TyConApp" (tc_l == tc_r) >> matchList (matchType rn2) tys_l tys_r matchType rn2 (FunTy ty1_l ty2_l) (FunTy ty1_r ty2_r) = liftM2 (++) (matchType rn2 ty1_l ty1_r) (matchType rn2 ty2_l ty2_r) matchType rn2 (ForAllTy a_l ty_l) (ForAllTy a_r ty_r) = matchTyVarBndr rn2 a_l a_r $ \rn2 -> matchType rn2 ty_l ty_r +matchType _ (LitTy l_l) (LitTy l_r) = guard "matchType: LitTy" (l_l == l_r) >> return [] matchType _ _ _ = fail "matchType" -- TODO: match coercion instantiation?