Template Haskell: improve lifting for strings

When you have a (\s::String -> ....[| s |]....), the string
's' is lifted.  We used to get a chain of single-character
Cons nodes, correct but lots and lots of code.

This patch arranges to optimise that to a string literal. It does
so in two places:
  a) In TcExpr, if we know that s::String, we generate liftString directly
  b) In DsMeta, if we find a list of character literals, we convert to
     a string.  This catches a few cases that (a) does not

There an accompanying  patch in the template-haskell package,
adding Language.Haskell.TH.Syntax.liftString

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5303f9d..9aac831 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -23,7 +23,7 @@
 
 module DsMeta( dsBracket, 
               templateHaskellNames, qTyConName, nameTyConName,
-              liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
+              liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
               quoteExpName, quotePatName
                ) where
@@ -1757,12 +1757,13 @@ predTyConName     = thTc (fsLit "Pred")         predTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName :: Name
-returnQName   = thFun (fsLit "returnQ")   returnQIdKey
-bindQName     = thFun (fsLit "bindQ")     bindQIdKey
-sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
+    mkNameLName, liftStringName :: Name
+returnQName    = thFun (fsLit "returnQ")   returnQIdKey
+bindQName      = thFun (fsLit "bindQ")     bindQIdKey
+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
 newNameName    = thFun (fsLit "newName")   newNameIdKey
-liftName      = thFun (fsLit "lift")      liftIdKey
+liftName       = thFun (fsLit "lift")      liftIdKey
+liftStringName = thFun (fsLit "liftString")  liftStringIdKey
 mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
 mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
 mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
@@ -2053,6 +2054,9 @@ floatPrimLIdKey   = mkPreludeMiscIdUnique 215
 doublePrimLIdKey  = mkPreludeMiscIdUnique 216
 rationalLIdKey    = mkPreludeMiscIdUnique 217
 
+liftStringIdKey :: Unique
+liftStringIdKey     = mkPreludeMiscIdUnique 218
+
 -- data Pat = ...
 litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,
     asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique
@@ -2081,6 +2085,7 @@ matchIdKey          = mkPreludeMiscIdUnique 231
 clauseIdKey :: Unique
 clauseIdKey         = mkPreludeMiscIdUnique 232
 
+
 -- data Exp = ...
 varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
     sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index fc915db..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 }

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 1508995..784d466 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -1152,18 +1152,33 @@ thBrackId orig id ps_var lie_var
                -- so we zap it to a LiftedTypeKind monotype
                -- C.f. the call in TcPat.newLitInst
 
-       ; setLIEVar lie_var     $ do
-       { lift <- newMethodFromName orig id_ty' DsMeta.liftName
-                  -- Put the 'lift' constraint into the right LIE
+       ; lift <- if isStringTy id_ty' then
+                    tcLookupId DsMeta.liftStringName
+                    -- See Note [Lifting strings]
+                 else
+                     setLIEVar lie_var $ do  -- Put the 'lift' constraint into the right LIE
+                     newMethodFromName orig id_ty' DsMeta.liftName
           
                   -- Update the pending splices
        ; ps <- readMutVar ps_var
        ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
 
-       ; return id } }
+       ; return id }
 #endif /* GHCI */
 \end{code}
 
+Note [Lifting strings]
+~~~~~~~~~~~~~~~~~~~~~~
+If we see $(... [| s |] ...) where s::String, we don't want to
+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
+So this conditional short-circuits the lifting mechanism to generate
+(liftString "xy") in that case.  I didn't want to use overlapping instances
+for the Lift class in TH.Syntax, because that can lead to overlapping-instance
+errors in a polymorphic situation.  
+
+If this check fails (which isn't impossible) we get another chance; see
+Note [Converting strings] in Convert.lhs 
+
 Local record selectors
 ~~~~~~~~~~~~~~~~~~~~~~
 Record selectors for TyCons in this module are ordinary local bindings,