X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=31382c20a36e0f1afd540242dbff2fb25915b031;hp=d5fc150904c7d51dcd6691472fe1dfb2f0eb787c;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=57217f68d74c803a189942eb99eed56610ad296b diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index d5fc150..31382c2 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,23 +7,31 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, + rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec + checkPrecMatch, checkSectionPrec, + + -- Splice related stuff + rnSplice, checkTH ) 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 @@ -108,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) @@ -123,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 @@ -148,14 +153,21 @@ rnHsType doc (HsListTy ty) = do ty' <- rnLHsType doc ty return (HsListTy ty') -rnHsType doc (HsKindSig ty k) = do - ty' <- rnLHsType doc ty - return (HsKindSig ty' k) +rnHsType doc (HsKindSig ty k) + = do { kind_sigs_ok <- xoptM Opt_KindSignatures + ; unless kind_sigs_ok (addErr (kindSigErr ty)) + ; ty' <- rnLHsType doc ty + ; return (HsKindSig ty' k) } 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 @@ -171,14 +183,24 @@ rnHsType doc (HsPredTy pred) = do pred' <- rnPred doc pred return (HsPredTy pred') -rnHsType _ (HsSpliceTy _) = - failWith (ptext (sLit "Type splices are not yet implemented")) +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 @@ -186,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 @@ -199,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} %********************************************************* @@ -435,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 @@ -536,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))] $$ @@ -557,3 +589,56 @@ opTyErr op ty@(HsOpTy ty1 _ _) forall_head _other = False opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) \end{code} + +%********************************************************* +%* * + Splices +%* * +%********************************************************* + +Note [Splices] +~~~~~~~~~~~~~~ +Consider + f = ... + h = ...$(thing "f")... + +The splice can expand into literally anything, so when we do dependency +analysis we must assume that it might mention 'f'. So we simply treat +all locally-defined names as mentioned by any splice. This is terribly +brutal, but I don't see what else to do. For example, it'll mean +that every locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', +and that will crash the type checker because 'f' isn't in scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +\begin{code} +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice (HsSplice n expr) + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc n) + ; (expr', fvs) <- rnLExpr expr + + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (occEnvElts lcl_rdr) + + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + +checkTH :: Outputable a => a -> String -> RnM () +#ifdef GHCI +checkTH _ _ = return () -- OK +#else +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "illegal in a stage-1 compiler"), + nest 2 (ppr e)]) +#endif +\end{code}