[commit: ghc] wip/gadtpm: Fixed #9951 and the same with OverloadedStrings (8a49fb2)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/8a49fb265a9e84d39325b5b236a07c582c6548eb/ghc

>---------------------------------------------------------------

commit 8a49fb265a9e84d39325b5b236a07c582c6548eb
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Mon Oct 12 16:22:38 2015 +0200

    Fixed #9951 and the same with OverloadedStrings


>---------------------------------------------------------------

8a49fb265a9e84d39325b5b236a07c582c6548eb
 compiler/deSugar/Check.hs           | 26 ++++++++++++++++++++------
 compiler/prelude/TysWiredIn.hs-boot |  2 +-
 compiler/types/Type.hs              | 12 ++++++++++--
 3 files changed, 31 insertions(+), 9 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 406806f..a4cad2a 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -221,6 +221,16 @@ mkPosLitPattern lit = NonGuard $ PmLit { pm_lit_lit = PmOLit False lit }
 mkNegLitPattern :: HsOverLit Id -> Pattern
 mkNegLitPattern lit = NonGuard $ PmLit { pm_lit_lit = PmOLit True lit }
 
+-- Specifically for overloaded strings. If we know that an overloaded x is a
+-- string, we can remove the fromString function since we know that it is the
+-- identity.
+oStrToHsLit_mb :: HsOverLit Id -> Maybe HsLit
+oStrToHsLit_mb olit
+  | ol_type olit == stringTy
+  , HsIsString src fs <- ol_val olit
+  = Just (HsString src fs)
+  | otherwise = Nothing
+
 -- -----------------------------------------------------------------------
 -- | Transform a Pat Id into a list of (PmPat Id) -- Note [Translation to PmPat]
 
@@ -266,12 +276,15 @@ translatePat pat = case pat of
     foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec (map unLoc ps)
 
   -- overloaded list
-  ListPat lpats elem_ty (Just (pat_ty, to_list)) -> do
-    (xp, xe) <- mkPmId2FormsSM pat_ty
-    ps       <- translatePatVec (map unLoc lpats) -- list as value abstraction
-    let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
-        g  = mkGuard pats (HsApp (noLoc to_list) xe) -- [...] <- toList x
-    return [xp,g]
+  ListPat lpats elem_ty (Just (pat_ty, to_list))
+    | Just e_ty <- splitListTyConApp_maybe pat_ty ->
+        translatePat (ListPat lpats e_ty Nothing) -- ensure that e_ty and elem_ty are the same?? (check OverlappingInstances)
+    | otherwise -> do
+        (xp, xe) <- mkPmId2FormsSM pat_ty
+        ps       <- translatePatVec (map unLoc lpats) -- list as value abstraction
+        let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
+            g  = mkGuard pats (HsApp (noLoc to_list) xe) -- [...] <- toList x
+        return [xp,g]
 
   ConPatOut { pat_con = L _ (PatSynCon _) } -> do
     -- Pattern synonyms have a "matcher" (see Note [Pattern synonym representation] in PatSyn.hs
@@ -295,6 +308,7 @@ translatePat pat = case pat of
                               , pm_con_args    = args }]
 
   NPat lit mb_neg _eq
+    | Just hs_lit <- oStrToHsLit_mb lit -> translatePat (LitPat hs_lit) -- overloaded string
     | Just _  <- mb_neg -> return [mkNegLitPattern lit] -- negated literal
     | Nothing <- mb_neg -> return [mkPosLitPattern lit] -- non-negated literal
 
diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot
index 309dfa2..a001338 100644
--- a/compiler/prelude/TysWiredIn.hs-boot
+++ b/compiler/prelude/TysWiredIn.hs-boot
@@ -4,6 +4,6 @@ import {-# SOURCE #-} TyCon      (TyCon)
 import {-# SOURCE #-} TypeRep    (Type)
 
 
-eqTyCon, coercibleTyCon :: TyCon
+eqTyCon, listTyCon, coercibleTyCon :: TyCon
 typeNatKind, typeSymbolKind :: Type
 mkBoxedTupleTy :: [Type] -> Type
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index ab4d2dc..ac18e35 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -29,7 +29,8 @@ module Type (
 
         mkTyConApp, mkTyConTy,
         tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,
-        splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole,
+	splitTyConApp_maybe, splitTyConApp, tyConAppArgN, splitListTyConApp_maybe,
+        nextRole,
 
         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
         mkPiKinds, mkPiType, mkPiTypes,
@@ -160,7 +161,7 @@ import NameEnv
 import Class
 import TyCon
 import TysPrim
-import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
+import {-# SOURCE #-} TysWiredIn ( eqTyCon, listTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
 import PrelNames ( eqTyConKey, coercibleTyConKey,
                    ipClassNameKey, openTypeKindTyConKey,
                    constraintKindTyConKey, liftedTypeKindTyConKey )
@@ -563,6 +564,13 @@ splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitTyConApp_maybe _                 = Nothing
 
+-- | Attempts to tease a list type apart and gives the type of the elements if
+-- successful (looks through type synonyms)
+splitListTyConApp_maybe :: Type -> Maybe Type
+splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of
+  Just (tc,[e]) | tc == listTyCon -> Just e
+  _other                          -> Nothing
+
 -- | What is the role assigned to the next parameter of this type? Usually,
 -- this will be 'Nominal', but if the type is a 'TyConApp', we may be able to
 -- do better. The type does *not* have to be well-kinded when applied for this