Template Haskell: improve lifting for strings

[ghc-hetmet.git] / compiler / hsSyn / Convert.lhs

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 1a9e190..b4d897d 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -508,7 +508,10 @@ cvtl e = wrapL (cvt e)
     cvt (DoE ss)       = cvtHsDo DoExpr ss
     cvt (CompE ss)     = cvtHsDo ListComp ss
     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
-    cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
+    cvt (ListE xs)     
+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
+            -- Note [Converting strings]
+      | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
                                          ; e' <- returnL $ OpApp x' s' undefined y'
                                          ; return $ HsPar e' }
@@ -597,6 +600,21 @@ cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 -- An Integer is like an (overloaded) '3' in a Haskell source program
 -- Similarly 3.5 for fractionals
 
+{- Note [Converting strings] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
+a string literal for "xy".  Of course, we might hope to get 
+(LitE (StringL "xy")), but not always, and allCharLs fails quickly
+if it isn't a literal string
+-}
+
+allCharLs :: [TH.Exp] -> Maybe String
+-- Note [Converting strings]
+allCharLs (LitE (CharL c) : xs) 
+  | Just cs <- allCharLs xs = Just (c:cs)
+allCharLs [] = Just []
+allCharLs _  = Nothing
+
 cvtLit :: Lit -> CvtM HsLit
 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
@@ -630,6 +648,7 @@ cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatI
 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
                           ; return $ ConPatIn s' (InfixCon p1' p2') }
 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
+cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 cvtp TH.WildP         = return $ WildPat void
 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 
@@ -874,7 +893,7 @@ mk_ghc_ns TH.VarName   = OccName.varName
 mk_mod :: TH.ModName -> ModuleName
 mk_mod mod = mkModuleName (TH.modString mod)
 
-mk_pkg :: TH.ModName -> PackageId
+mk_pkg :: TH.PkgName -> PackageId
 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 
 mk_uniq :: Int# -> Unique