Add HsCoreTy to HsType

[ghc-hetmet.git] / compiler / rename / RnTypes.lhs

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 3086b94..b275d2d 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -18,6 +18,9 @@ module RnTypes (
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
+#endif         /* GHCI */
 
 import DynFlags
 import HsSyn
@@ -159,7 +162,7 @@ rnHsType doc (HsListTy ty) = do
 
 rnHsType doc (HsKindSig ty k)
   = do { kind_sigs_ok <- doptM Opt_KindSignatures
-       ; checkM kind_sigs_ok (addErr (kindSigErr ty))
+       ; unless kind_sigs_ok (addErr (kindSigErr ty))
        ; ty' <- rnLHsType doc ty
        ; return (HsKindSig ty' k) }
 
@@ -182,15 +185,24 @@ rnHsType doc (HsPredTy pred) = do
     pred' <- rnPred doc pred
     return (HsPredTy pred')
 
-rnHsType _ (HsSpliceTy sp)
-  = do { (sp', _fvs) <- rnSplice sp    -- ToDo: deal with fvs
-       ; return (HsSpliceTy sp') }
+rnHsType _ (HsSpliceTy sp _ k)
+  = do { (sp', fvs) <- rnSplice sp     -- ToDo: deal with fvs
+       ; return (HsSpliceTy sp' fvs k) }
 
 rnHsType doc (HsDocTy ty haddock_doc) = do
     ty' <- rnLHsType doc ty
     haddock_doc' <- rnLHsDoc haddock_doc
     return (HsDocTy ty' haddock_doc')
 
+#ifndef GHCI
+rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
+#else
+rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
+                                      ; rnHsType doc (unLoc ty) }
+#endif
+rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
+
+--------------
 rnLHsTypes :: SDoc -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
@@ -198,7 +210,7 @@ rnLHsTypes doc tys = mapM (rnLHsType doc) tys
 
 
 \begin{code}
-rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
         -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
@@ -211,7 +223,7 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
        -- of kind *.
 
 rnForAll doc exp forall_tyvars ctxt ty
-  = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
+  = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do
     new_ctxt <- rnContext doc ctxt
     new_ty <- rnLHsType doc ty
     return (HsForAllTy exp new_tyvars new_ctxt new_ty)
@@ -457,18 +469,18 @@ not_op_pat (ConPatIn _ (InfixCon _ _)) = False
 not_op_pat _                          = True
 
 --------------------------------------
-checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
-       -- True indicates an infix lhs
-       -- See comments with rnExpr (OpApp ...) about "deriving"
+checkPrecMatch :: Name -> MatchGroup Name -> RnM ()
+  -- Check precedence of a function binding written infix
+  --   eg  a `op` b `C` c = ...
+  -- See comments with rnExpr (OpApp ...) about "deriving"
 
-checkPrecMatch False _ _
-  = return ()
-checkPrecMatch True op (MatchGroup ms _)       
+checkPrecMatch op (MatchGroup ms _)    
   = mapM_ check ms                             
   where
-    check (L _ (Match (p1:p2:_) _ _))
-      = do checkPrec op (unLoc p1) False
-           checkPrec op (unLoc p2) True
+    check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
+      = setSrcSpan (combineSrcSpans l1 l2) $
+        do checkPrec op p1 False
+           checkPrec op p2 True
 
     check _ = return ()        
        -- This can happen.  Consider
@@ -610,7 +622,7 @@ rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 rnSplice (HsSplice n expr)
   = do { checkTH expr "splice"
        ; loc  <- getSrcSpanM
-       ; [n'] <- newLocalsRn [L loc n]
+       ; n' <- newLocalBndrRn (L loc n)
        ; (expr', fvs) <- rnLExpr expr
 
        -- Ugh!  See Note [Splices] above