X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=31382c20a36e0f1afd540242dbff2fb25915b031;hp=61731e8726c9db1d9ff5cbf30e569047e1b14809;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=389cca214f33a29646e08d57e3dca862140007b2 diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 61731e8..31382c2 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,7 +7,7 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, + rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, @@ -18,17 +18,20 @@ module RnTypes ( ) where import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) +#endif /* GHCI */ import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn ( extractHsTyNames ) -import RnHsDoc ( rnLHsDoc ) +import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad import RdrName import PrelNames -import TypeRep ( funTyConName ) +import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet @@ -113,7 +116,7 @@ rnHsType _ (HsTyVar tyvar) = do -- Hence the jiggery pokery with ty1 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) = setSrcSpan loc $ - do { ops_ok <- doptM Opt_TypeOperators + do { ops_ok <- xoptM Opt_TypeOperators ; op' <- if ops_ok then lookupOccRn op else do { addErr (opTyErr op ty) @@ -128,16 +131,13 @@ rnHsType doc (HsParTy ty) = do ty' <- rnLHsType doc ty return (HsParTy ty') -rnHsType doc (HsBangTy b ty) = do - ty' <- rnLHsType doc ty - return (HsBangTy b ty') +rnHsType doc (HsBangTy b ty) + = do { ty' <- rnLHsType doc ty + ; return (HsBangTy b ty') } -rnHsType _ (HsNumTy i) - | i == 1 = return (HsNumTy i) - | otherwise = addErr err_msg >> return (HsNumTy i) - where - err_msg = ptext (sLit "Only unit numeric type pattern is valid") - +rnHsType doc (HsRecTy flds) + = do { flds' <- rnConDeclFields doc flds + ; return (HsRecTy flds') } rnHsType doc (HsFunTy ty1 ty2) = do ty1' <- rnLHsType doc ty1 @@ -154,8 +154,8 @@ rnHsType doc (HsListTy ty) = do return (HsListTy ty') rnHsType doc (HsKindSig ty k) - = do { kind_sigs_ok <- doptM Opt_KindSignatures - ; checkM kind_sigs_ok (addErr (kindSigErr ty)) + = do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (addErr (kindSigErr ty)) ; ty' <- rnLHsType doc ty ; return (HsKindSig ty' k) } @@ -163,6 +163,11 @@ rnHsType doc (HsPArrTy ty) = do ty' <- rnLHsType doc ty return (HsPArrTy ty') +rnHsType doc (HsModalBoxType ecn ty) = do + ecn' <- lookupOccRn ecn + ty' <- rnLHsType doc ty + return (HsModalBoxType ecn' ty') + -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (HsTupleTy tup_con tys) = do @@ -178,15 +183,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 @@ -194,7 +208,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 @@ -207,12 +221,22 @@ 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) -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly + +rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name] +rnConDeclFields doc fields = mapM (rnField doc) fields + +rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) +rnField doc (ConDeclField name ty haddock_doc) + = do { new_name <- lookupLocatedTopBndrRn name + ; new_ty <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (ConDeclField new_name new_ty new_haddock_doc) } \end{code} %********************************************************* @@ -443,18 +467,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 @@ -544,7 +568,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName -> TcRnIf TcGblEnv TcLclEnv () forAllWarn doc ty (L loc tyvar) - = ifOptM Opt_WarnUnusedMatches $ + = ifDOptM Opt_WarnUnusedMatches $ addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] $$ @@ -596,7 +620,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