From: Ian Lynagh Date: Tue, 6 May 2008 20:18:29 +0000 (+0000) Subject: Make TcHsSyn warning-free X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5cc7a60d61272715174bed1e4d24e9d0bf5db2b7;hp=268072d6aeb40026d387278f7e3d73f749bfbd92 Make TcHsSyn warning-free --- diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index defa5bf..e6e95b3 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -9,13 +9,6 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcHsSyn ( mkHsConApp, mkHsDictLet, mkHsApp, hsLitType, hsLPatType, hsPatType, @@ -97,36 +90,38 @@ mkVanillaTuplePat pats box hsLPatType :: OutPat Id -> Type hsLPatType (L _ pat) = hsPatType pat -hsPatType (ParPat pat) = hsLPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat var) = idType var -hsPatType (VarPatOut var _) = idType var -hsPatType (BangPat pat) = hsLPatType pat -hsPatType (LazyPat pat) = hsLPatType pat -hsPatType (LitPat lit) = hsLitType lit -hsPatType (AsPat var pat) = idType (unLoc var) -hsPatType (ViewPat expr pat ty) = ty -hsPatType (ListPat _ ty) = mkListTy ty -hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat pats box ty) = ty -hsPatType (ConPatOut{ pat_ty = ty })= ty -hsPatType (SigPatOut pat ty) = ty -hsPatType (NPat lit _ _) = overLitType lit -hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) -hsPatType (CoPat _ _ ty) = ty +hsPatType :: Pat Id -> Type +hsPatType (ParPat pat) = hsLPatType pat +hsPatType (WildPat ty) = ty +hsPatType (VarPat var) = idType var +hsPatType (VarPatOut var _) = idType var +hsPatType (BangPat pat) = hsLPatType pat +hsPatType (LazyPat pat) = hsLPatType pat +hsPatType (LitPat lit) = hsLitType lit +hsPatType (AsPat var _) = idType (unLoc var) +hsPatType (ViewPat _ _ ty) = ty +hsPatType (ListPat _ ty) = mkListTy ty +hsPatType (PArrPat _ ty) = mkPArrTy ty +hsPatType (TuplePat _ _ ty) = ty +hsPatType (ConPatOut { pat_ty = ty }) = ty +hsPatType (SigPatOut _ ty) = ty +hsPatType (NPat lit _ _) = overLitType lit +hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) +hsPatType (CoPat _ _ ty) = ty +hsPatType p = pprPanic "hsPatType" (ppr p) hsLitType :: HsLit -> TcType -hsLitType (HsChar c) = charTy -hsLitType (HsCharPrim c) = charPrimTy -hsLitType (HsString str) = stringTy -hsLitType (HsStringPrim s) = addrPrimTy -hsLitType (HsInt i) = intTy -hsLitType (HsIntPrim i) = intPrimTy -hsLitType (HsWordPrim w) = wordPrimTy -hsLitType (HsInteger i ty) = ty -hsLitType (HsRat _ ty) = ty -hsLitType (HsFloatPrim f) = floatPrimTy -hsLitType (HsDoublePrim d) = doublePrimTy +hsLitType (HsChar _) = charTy +hsLitType (HsCharPrim _) = charPrimTy +hsLitType (HsString _) = stringTy +hsLitType (HsStringPrim _) = addrPrimTy +hsLitType (HsInt _) = intTy +hsLitType (HsIntPrim _) = intPrimTy +hsLitType (HsWordPrim _) = wordPrimTy +hsLitType (HsInteger _ ty) = ty +hsLitType (HsRat _ ty) = ty +hsLitType (HsFloatPrim _) = floatPrimTy +hsLitType (HsDoublePrim _) = doublePrimTy \end{code} Overloaded literals. Here mainly becuase it uses isIntTy etc @@ -201,6 +196,7 @@ data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type -- Maps an Id to its zonked version; both have the same Name -- Is only consulted lazily; hence knot-tying +emptyZonkEnv :: ZonkEnv emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv @@ -233,10 +229,11 @@ zonkIdOcc :: ZonkEnv -> TcId -> Id -- -- Even without template splices, in module Main, the checking of -- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv zonk_ty env) id +zonkIdOcc (ZonkEnv _zonk_ty env) id | isLocalVar id = lookupVarEnv env id `orElse` id | otherwise = id +zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] zonkIdOccs env ids = map (zonkIdOcc env) ids -- zonkIdBndr is used *after* typechecking to get the Id's type @@ -253,6 +250,7 @@ zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var] -- "Dictionary" binders can be coercion variables or dictionary variables zonkDictBndrs env ids = mappM (zonkDictBndr env) ids +zonkDictBndr :: ZonkEnv -> Var -> TcM Var zonkDictBndr env var | isTyVar var = return var | otherwise = zonkIdBndr env var @@ -305,8 +303,8 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) --------------------------------------------- zonkValBinds :: ZonkEnv -> HsValBinds TcId -> TcM (ZonkEnv, HsValBinds Id) -zonkValBinds env bs@(ValBindsIn _ _) - = panic "zonkValBinds" -- Not in typechecker output +zonkValBinds _ (ValBindsIn _ _) + = panic "zonkValBinds" -- Not in typechecker output zonkValBinds env (ValBindsOut binds sigs) = do { (env1, new_binds) <- go env binds ; return (env1, ValBindsOut new_binds sigs) } @@ -432,7 +430,7 @@ zonkExpr env (HsLit (HsRat f ty)) = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (HsLit (HsRat f new_ty)) -zonkExpr env (HsLit lit) +zonkExpr _ (HsLit lit) = returnM (HsLit lit) zonkExpr env (HsOverLit lit) @@ -455,7 +453,7 @@ zonkExpr env (HsBracketOut body bs) zonk_b (n,e) = zonkLExpr env e `thenM` \ e' -> returnM (n,e') -zonkExpr env (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen +zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen returnM (HsSpliceE s) zonkExpr env (OpApp e1 op fixity e2) @@ -536,7 +534,7 @@ zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySigOut e' ty) } -zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" +zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" zonkExpr env (ArithSeq expr info) = zonkExpr env expr `thenM` \ new_expr -> @@ -583,11 +581,12 @@ zonkExpr env (HsWrap co_fn expr) zonkExpr env1 expr `thenM` \ new_expr -> return (HsWrap new_co_fn new_expr) -zonkExpr env other = pprPanic "zonkExpr" (ppr other) +zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd +zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) = zonkLExpr env cmd `thenM` \ new_cmd -> zonkTcTypeToTypes env stack_tys `thenM` \ new_stack_tys -> @@ -620,7 +619,7 @@ zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name -- Only used for 'do', so the only Ids are in a MDoExpr table zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl) -zonkDo env do_or_lc = do_or_lc +zonkDo _ do_or_lc = do_or_lc ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) @@ -736,7 +735,8 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr env Nothing = return Nothing +zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) +zonkMaybeLExpr _ Nothing = return Nothing zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) @@ -770,6 +770,7 @@ zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id) -- to the right) zonkPat env pat = wrapLocSndM (zonk_pat env) pat +zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id) zonk_pat env (ParPat p) = do { (env', p') <- zonkPat env p ; return (env', ParPat p') } @@ -859,9 +860,13 @@ zonk_pat env (CoPat co_fn pat ty) ; ty' <- zonkTcTypeToType env'' ty ; return (env'', CoPat co_fn' (unLoc pat') ty') } -zonk_pat env pat = pprPanic "zonk_pat" (ppr pat) +zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) --------------------------- +zonkConStuff :: ZonkEnv + -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId)) + -> TcM (ZonkEnv, + HsConDetails (OutPat Id) (HsRecFields id (OutPat Id))) zonkConStuff env (PrefixCon pats) = do { (env', pats') <- zonkPats env pats ; return (env', PrefixCon pats') } @@ -878,6 +883,7 @@ zonkConStuff env (RecCon (HsRecFields rpats dd)) -- Field selectors have declared types; hence no zonking --------------------------- +zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id]) zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat ; (env', pats') <- zonkPats env1 pats @@ -896,9 +902,9 @@ zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) -zonkForeignExport env (ForeignExport i hs_ty spec) = +zonkForeignExport env (ForeignExport i _hs_ty spec) = returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec) -zonkForeignExport env for_imp +zonkForeignExport _ for_imp = returnM for_imp -- Foreign imports don't need zonking \end{code} @@ -950,6 +956,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) | isId (unLoc v) = wrapLocM (zonkIdBndr env) v | otherwise = ASSERT( isImmutableTyVar (unLoc v) ) return v + zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" \end{code}