Fix Trac #3966: warn about useless UNPACK pragmas

[ghc-hetmet.git] / compiler / typecheck / TcSplice.lhs

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 8ee43f5..bafddf8 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -46,6 +46,7 @@ import TcIface
 import TypeRep
 import Name
 import NameEnv
+import NameSet
 import PrelNames
 import HscTypes
 import OccName
@@ -73,6 +74,7 @@ import BasicTypes
 import Panic
 import FastString
 import Exception
+import Control.Monad   ( when )
 
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
@@ -284,7 +286,7 @@ The predicate we use is TcEnv.thTopLevelId.
 tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
 tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
-kcSpliceType  :: HsSplice Name -> TcM (HsType Name, TcKind)
+kcSpliceType  :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
        -- None of these functions add constraints to the LIE
 
 lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
@@ -300,7 +302,7 @@ runAnnotation     :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
 tcBracket     x _ = pprPanic "Cant do tcBracket without GHCi"     (ppr x)
 tcSpliceExpr  e   = pprPanic "Cant do tcSpliceExpr without GHCi"  (ppr e)
 tcSpliceDecls x   = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
-kcSpliceType  x   = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
+kcSpliceType  x fvs = pprPanic "Cant do kcSpliceType without GHCi"  (ppr x)
 
 lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
 
@@ -495,7 +497,7 @@ tcTopSpliceExpr tc_action
 Very like splicing an expression, but we don't yet share code.
 
 \begin{code}
-kcSpliceType (HsSplice name hs_expr)
+kcSpliceType splice@(HsSplice name hs_expr) fvs
   = setSrcSpan (getLoc hs_expr) $ do   
     { stage <- getStage
     ; case stage of {
@@ -518,11 +520,8 @@ kcSpliceType (HsSplice name hs_expr)
     -- Here (h 4) :: Q Type
     -- but $(h 4) :: a         i.e. any type, of any kind
 
-    -- We return a HsSpliceTyOut, which serves to convey the kind to 
-    -- the ensuing TcHsType.dsHsType, which makes up a non-committal
-    -- type variable of a suitable kind
     ; kind <- newKindVar
-    ; return (HsSpliceTyOut kind, kind)        
+    ; return (HsSpliceTy splice fvs kind, kind)        
     }}}
 
 kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind)
@@ -657,15 +656,16 @@ runQuasiQuote :: Outputable hs_syn
               -> RnM hs_syn
 runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
   = do { quoter' <- lookupOccRn quoter
-               -- If 'quoter' is not in scope, proceed no further
-               -- Otherwise lookupOcc adds an error messsage and returns 
-               -- an "unubound name", which makes the subsequent attempt to
-               -- run the quote fail
-               --
                -- We use lookupOcc rather than lookupGlobalOcc because in the
                -- erroneous case of \x -> [x| ...|] we get a better error message
                -- (stage restriction rather than out of scope).
 
+        ; when (isUnboundName quoter') failM 
+               -- If 'quoter' is not in scope, proceed no further
+               -- The error message was generated by lookupOccRn, but it then
+               -- succeeds with an "unbound name", which makes the subsequent 
+               -- attempt to run the quote fail in a confusing way
+
           -- Check that the quoter is not locally defined, otherwise the TH
           -- machinery will not be able to run the quasiquote.
        ; this_mod <- getModule
@@ -1121,7 +1121,7 @@ reifyKind  ki
         kis_rep    = map reifyKind kis
         ki'_rep    = reifyNonArrowKind ki'
     in
-    foldl TH.ArrowK ki'_rep kis_rep
+    foldr TH.ArrowK ki'_rep kis_rep
   where
     reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
                         | otherwise          = pprPanic "Exotic form of kind" 
@@ -1197,10 +1197,9 @@ reifyFixity name
       conv_dir BasicTypes.InfixL = TH.InfixL
       conv_dir BasicTypes.InfixN = TH.InfixN
 
-reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
-reifyStrict MarkedStrict    = TH.IsStrict
-reifyStrict MarkedUnboxed   = TH.IsStrict
-reifyStrict NotMarkedStrict = TH.NotStrict
+reifyStrict :: BasicTypes.HsBang -> TH.Strict
+reifyStrict bang | isBanged bang = TH.IsStrict
+                 | otherwise     = TH.NotStrict
 
 ------------------------------
 noTH :: LitString -> SDoc -> TcM a